Dr. Windows 3

home *** CD-ROM | disk | FTP | other *** search

/ Dr. Windows 3 / dr win3.zip / dr win3 / NEW_TECH / JX4NT1.ZIP / JAX4TH.A < prev next >

Wrap

Text File | 1993-12-30 | 112KB | 4,480 lines

TITLE jax4th.asm PAGE ,116 ; jax4th.a ... 32-bit ANS Forth for Windows NT ; copyright (c) 1993 by jack j. woehr ; p.o. box 51, golden, co 80402-0051 ; jax@well.sf.ca.us | JAX on GEnie | 72203.1320@compuserve.com ; sysop, rcfb (303) 278-0364 COMMENT ! This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. (doc\license.txt) You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ ! .386P .XLIST include listing.inc ; this may not be needed .LIST include jax4th.i _TEXT SEGMENT DWORD USE32 PUBLIC 'CODE' _TEXT ENDS _DATA SEGMENT DWORD USE32 PUBLIC 'DATA' _DATA ENDS ASSUME CS: FLAT, DS: FLAT, SS: FLAT _DATA SEGMENT DWORD USE32 PUBLIC 'DATA' .SALL ; suppress listing of Unicode macro expansion myMsg: unicode <Jax4th for Windows NT> DW 0ah, 0dh unicode <Copyright (c) 1993, Jack J. Woehr> DW 0ah, 0dh unicode <Covered under the GNU Public License.> DW 0ah, 0dh myMsgLen = ($-myMsg)/tchar orderMsg0: unicode <Search Order: > orderMsg0Len = ($-orderMsg0)/tchar orderMsg1: unicode <Current Compilation Wordlist: > orderMsg1Len = ($-orderMsg1)/tchar throwMsg: unicode <THROW #> throwMsgLen = ($-throwMsg)/tchar byeMsg: unicode <Bye> DW 0ah, 0dh byeMsgLen = ($-byeMsg)/tchar gnuMsg: unicode < Jax4th 1.06 (C) 1993 Jack J. Woehr> DW 0ah, 0dh unicode < Jax4th comes with ABSOLUTELY NO WARRANTY.> DW 0ah, 0dh unicode < This is free software, and you are welcome to redistribute it > DW 0ah, 0dh unicode < under certain conditions. See file COPYING.TXT for more info.> DW 0ah, 0dh unicode < Type ABOUT to see this message again.> DW 0ah, 0dh gnuMsgLen = ($-gnuMsg)/tchar ;--( Forth Messages ) okPrompt: dw 3 unicode < ok> listMsg1: dw 7 unicode <Block: > listMsg2: dw 9 unicode <File ID: > stackUnderMsg: dw 12 unicode <Stack under.> undefinedMsg dw 10 unicode <Undefined.> compOnlyMsg dw 17 unicode <Compilation only.> toBodyMsg dw 22 unicode <Not a child of CREATE.> blockWriteMsg dw 18 unicode <BLOCK write error.> blockReadMsg dw 17 unicode <BLOCK read error.> blockNumMsg dw 21 unicode <Invalid BLOCK number.> fileIOMsg dw 20 unicode <File I/O exception: > cStackMsg dw 20 unicode <Control stack error.> conStructMsg dw 26 unicode <Control structure mismatch.> zeroStringMsg dw 17 unicode <Zero-length name.> srchOverMsg dw 22 unicode <Search order overflow.> srchUnderMsg dw 23 unicode <Search order underflow.> compNestMsg dw 17 unicode <Compiler nesting.> ;--( Various Messages ) dumpHdr: dw 56 unicode <Address 0100 0302 0504 0706 0908 0B0A 0D0C 0F0E Unicode> unnamedHdr: dw 7 unicode <UNNAMED> wlHdr: dw 11 unicode <Wordlists: > .XALL ; back to normal listing of macro expansion ;--( Kernel Variables) numWritten DD ? ; for calls to WriteConsoleW secAttrib SECURITY_ATTRIBUTES <> ; for calls to CreateFileW fileInfo _BY_HANDLE_FILE_INFORMATION <> ; for calls to GetFileInformationByHandle numRead DD ? ; number of chars read distMoveHigh DD ? ; used by REPOSITION-FILE lastReadConW DW ? ; used by KEY and others inRecArray INPUT_RECORD 256 DUP (<>) ; for KEY? _DATA ENDS _TEXT SEGMENT DWORD USE32 PUBLIC 'CODE' ;-------------------------------; ; Define API Entry ; ;-------------------------------; PUBLIC _mainCRTStartup ; satisfies console subsystem ;-----------------------; ; Main Program ; ;-----------------------; _mainCRTStartup PROC NEAR ; enter program ;--( Console subsys code swiped from entry after the C runtime startup. Without this code, Console API doesn't work!) ;--( This is still a bif of a mystery to us.) push ebp mov ebp, esp sub esp, 20 push ebx push esi push edi ;--( End of apparently obligatory prelude) cld ; !!!***!!! NEXT depends on it, it's this way at boot anyway, but for good luck! jmp boot ; apropos the above, see MOVE ;---------------; ; Forth ; ;---------------; ;--( Execution ) ; Implementation detail zname <NEST> ; this doesn't have an exe engine, it *is* one, musn't be called from Forth interpretively nest: pushrp ip ; @(--RP) := IP lea ip,cell[wp] ; IP := @(WP+4) next zname <DOCONST> ; -- x push DWORD PTR cell[wp] ; Implementation detail next ; Execution engine, works for VARIABLE, also zname <DODOES> ; -- x ; Implementation detail push DWORD PTR cell[wp] ; push data pointer for this CREATE child mov wp,2*cell[wp] ; WP := xt for DOES> code dereftok ; now is a pointer jmp nest zname <UNNEST> ; -- x R: nest-sys -- docode ; Implementation detail poprpto ip ; IP := @RP++ next ; Same routine as above but different for a debugger to recognize fname <EXIT> ; -- R: nest-sys -- docode ; CORE poprpto ip ; IP := @RP++ next zname <DOKWORDLIST> ; -- a-addr ; Implementation detail, Execution engine for wordlists declared in the kernel lea edx,cell[wp] ; pointer to data space where list end is stored sub edx,dp ; convert abs address to data address push edx ; push next zname <DOWORDLIST> ; -- a-addr ; Implementation detail, Execution engine for wordlists created by user lea edx,cell[wp] ; get self-pointer of a Wordlist add edx,cp ; convert from user dict address to abs address sub edx,dp ; convert abs address to data address push eax ; push next fname <EXECUTE> ; i*x xt -- j*x docode ; CORE pop wp innext zname <DOLIT> ; -- x docode ; Implementation detail lodsd ; advance instruction pointer fetching literal value push eax ; push literal next zname <DODLIT> ; -- docode ; Implementation detail lodsd ; advance instruction pointer fetching literal value mov edx,eax ; save hi 32 bits lodsd ; advance instruction pointer fetching literal value push eax ; push literal loword push edx ; push literal hiword next zname <DOIF> ; flag -- docode ;Implementation detail, also is UNTIL pop eax and eax,eax ; test flag je doelse ; if zero, we branch add ip,cell ; wasn't zero, we advance IP next zname <DOELSE> ; -- docode ; Implementation detail, also is AGAIN, REPEAT doelse: mov wp,[ip] dereftok mov ip,wp next zname <DOUNTIL> ; flag -- docode ; Implementation detail pop eax and eax,eax ; test flag je doelse ; if zero, we branch add ip,cell ; was zero, we advance IP next zname <DOUNTILNOT> ; flag -- docode ; Implementation detail, used this once, not sure why .. pop eax and eax,eax ; test flag jne doelse ; if nonzero, we branch add ip,cell ; was zero, we advance IP next zname <DODO> ; u1 u2 -- docode ; Implementation detail dodo: lodsd ; WP := exit address dereftok pushrp wp ; save exit address on return stack pop eax ; inner loop index pop edx ; outer loop index add edx,80000000H ; add overflow limit to outer sub eax,edx ; massage inner pushrp edx ; push massaged outer to RStack pushrp eax ; push massaged inner to RStack next zname <DOQDO> ; u1 u2 -- docode ; Implementation detail mov edx,[esp] ; copy of TOS cmp cell[esp],edx ; compare to other index jne dodo ; they are different: go ahead and DO add esp,2*cell ; same: clear stack lodsd ; WP := @IP++ dereftok mov ip,wp ; IP := WP i.e., exit address compiled in cell ahead of DOQDO token next ; onwards zname <DOLOOP> ; -- docode ; Implementation detail doloop: poprpto eax ; massaged inner index inc eax ; increment jo doloop1 ; overflow flag, we're done pushrp eax ; not done, return incremented count lodsd ; WP := @IP++, i.e., WP is loaded with branchback address dereftok mov ip,wp ; IP := branch back next ; continue doloop1: add rp,2*cell ; clear return stack add ip,cell ; branch past loopback address next ; onwards and outwards zname <DOPLUSLOOP> ; n1 -- docode ; Implementation detail poprpto eax ; massaged inner index pop edx ; increment add eax,edx ; add increment to index jo doloop1 ; overflow flag, we're done, we can re-use the above code pushrp eax ; not done, return incremented count lodsd ; WP := @IP++, i.e., WP is loaded with branchback address dereftok mov ip,wp ; IP := branch back next ; continue ; Strings for S" and TYPE must reside in data space. In the dictionary they are recorded /DOSQUOTE/D-ADDR/ zname <DOSQUOTE> ; -- c-addr u docode ; Implementation detail lodsd ; count address in ax xor edx,edx ; clear dx mov dx,[eax][dp] ; get count add eax,tchar ; form data address of string push eax ; push c-addr push edx ; push u next zname <DODOTQUOTE> ; -- docode ; Implementation detail lodsd ; count address in wp (EAX) xor edx,edx ; clear dx mov dx,[eax+dp] ; get count add eax,tchar ; form data address of string push eax ; push c-addr push edx ; push u jmp ftype ; goto type zname <DOKDOTQUOTE> ; -- Print strings stored in the kernel exe data section docode ; Implementation detail. lodsd ; count address in wp (EAX) sub eax,dp ; convert to data-relative address xor edx,edx ; clear dx mov dx,[eax+dp] ; get count add eax,tchar ; form data address of string push eax ; push c-addr push edx ; push u jmp ftype ; goto typ ;--( Stack Operators ) fname <DROP> ; x -- docode ; CORE pop eax next fnamemanque <2DROP> ; x1 x2 -- fw_TWO_DROP: docode ; CORE pop eax pop eax next fnamemanque <?DUP> ; x -- x x | 0 fw_QDUP: docode ; CORE cmp DWORD PTR [esp],0 jne dupe next fname <DUP> ; x -- x x docode ; CORE dupe: push [esp] next fnamemanque <2DUP> ; x1 x2 -- x1 x2 x1 x2 fw_TWO_DUP: docode ; CORE push cell[esp] push cell[esp] next fname <OVER> ; x1 x2 -- x1 x2 x1 dd over ; CORE over: push cell[esp] next fnamemanque <2OVER> ; x1 x2 x3 x4-- x1 x2 x3 x4 x1 x2 fw_TWO_OVER: docode ; CORE push 3*cell[esp] push 3*cell[esp] next fname <ROT> ; x1 x2 x3 -- x2 x3 x1 docode ; CORE pop eax pop ecx pop edx push ecx push eax push edx next nnamemanque <-ROT> ; x1 x2 x3 -- x3 x1 x2 fw_NEGROT: ; Not in Standard docode pop eax pop ecx pop edx push eax push edx push ecx next fname <SWAP> ; x1 x2 -- x2 x1 docode ; CORE pop eax pop edx push eax push edx next fnamemanque <2SWAP> ; x1 x2 x3 x4-- x3 x4 x1 x2 fw_TWO_SWAP: ; CORE docode mov eax,3*cell[esp] mov edx,cell[esp] mov 3*cell[esp],edx mov cell[esp],eax mov eax,2*cell[esp] mov edx,[esp] mov 2*cell[esp],edx mov [esp],eax next ; Can't use our name header macros with this one! linkme flinkptr countcell 2 db '>',0,'R',0 ; x -- R: -- x align 4 ; CORE fw_TO_R: docode sub rp,cell pop [rp] next ; Can't use our name header macros with this one! linkme flinkptr countcell 2 db 'R',0,'>',0 ; -- x R: x -- align 4 ; CORE fw_R_FROM: docode push [rp] add rp,cell next fnamemanque <R@> ; -- x R: x -- x fw_R_FETCH: ; CORE docode push DWORD PTR [rp] next ; Can't use our name header macros with this one! linkme nlinkptr countcell 3 db 'R',0,'P',0,'!',0 ; addr -- align 4 ; Implementation fw_RP_STORE: docode pop rp next nnamemanque <RP@> fw_RP_FETCH: ; -- addr docode ; Implementation push rp next fname <TUCK> ; x1 x2 -- x2 x1 x2 docode ; CORE EXT pop eax pop edx push eax push edx push eax next fname <NIP> ; x1 x2 -- x2 docode ; CORE EXT pop eax pop edx push eax next fname <PICK> ; xu .. x1 x0 u -- xu .. x1 x0 xu docode ; CORE EXT pop eax push [esp][eax*cell] next fname <DEPTH> ; i*x -- i*x i ctok NEST ; CORE ctok SP_FETCH ; -- @esp ctok SP0 ctok FETCH ; -- @esp @orig-esp ctok SWAP ctok MINUS ; -- diff literal 1 ctok CELLS ; -- diff cell-size ctok SLASH ; -- cells-diff ctok UNNEST ; Get current data stack pointer value, an absolute address nnamemanque <SP@> ; -- abs-addr fw_SP_FETCH: ; Not in Standard docode push esp next ; Can't use our name header macros with this one! linkme nlinkptr countcell 3 db 'S',0,'P',0,'!' ; abs-addr -- Set data stack pointer value, an absolute address align 4 fw_SP_STORE: ; Not in Standard docode pop esp next ; Get saved-at-boot data stack pointer value nname <SP0> ; -- a-addr ctok DOCONST ; Not in Standard dd ntConESP ;--( Data Movement ) ; Can't use our name header macros with this one! linkme flinkptr countcell 1 db '!',0 ; x a-addr -- align 4 ; CORE fw_STORE: docode pop eax pop [eax][dp] next ; Can't use our name header macros with this one! linkme flinkptr countcell 2 db '+',0,'!',0 ; x a-addr -- align 4 ; CORE fw_PL_STORE: docode pop eax pop edx add [eax][dp],edx next fnamemanque <@> ; a-addr -- x fw_FETCH: docode ; CORE pop eax push [eax][dp] next ; Can't use our name header macros with this one! linkme flinkptr countcell 2 db 'C',0,'!',0 ; c c-addr -- align 4 ; CORE fw_C_STORE: docode pop eax pop edx mov [eax][dp],dx next fnamemanque <C@> ; c-addr -- c fw_C_FETCH: docode ; CORE mov eax,[esp] mov dx,[eax][dp] movzx eax,dx mov [esp],eax next ; Can't use our name header macros with this one! linkme nlinkptr countcell 2 db 'B',0,'!',0 ; byte c-addr -- align 4 ; Not in Standard fw_B_STORE: docode pop eax pop edx mov [eax][dp],dl next nnamemanque <B@> ; c-addr -- byte fw_B_FETCH: docode ; Not in Standard mov eax,[esp] mov dl,[eax][dp] movzx eax,dl mov [esp],eax next ; Can't use our name header macros with this one! linkme flinkptr countcell 2 db '2',0,'!',0 ; x1 x2 a-addr -- align 4 ; CORE fw_TWO_STORE: docode pop eax pop [eax][dp] pop [eax+cell][dp] next fnamemanque <2@> ; a-addr -- x1 x2 fw_TWO_FETCH: docode ; CORE pop eax push [eax+cell][dp] push [eax][dp] next ; Can't use our name header macros with this one! linkme flinkptr countcell 1 db ',',0 ; x -- align 4 ; CORE fw_COMMA: docode mov eax,[dp+datap] ; get data space pointer pop [eax][dp] ; pop to that offset in data space add DWORD PTR datap[dp],cell ; post-increment pointer next ; Can't use our name header macros with this one! linkme flinkptr countcell 2 db 'C',0,',',0 ; char -- align 4 ; CORE fw_CCOMMA: docode mov eax,[dp+datap] ; get data space pointer pop edx ; get char mov [eax][dp],dx ; pop char to that offset in data space add DWORD PTR datap[dp],tchar ; post-increment pointer next fname <MOVE> ; addr1 addr2 u -- docode pop ecx ; count pop eax ; destination pop edx ; source and ecx,ecx ; is count zero? je move2 ; if zero count, exit cld ; now set to move string upwards cmp eax,edx ; destination - source jb move1 ; jump if destination < source, continue further on add eax,ecx dec eax add edx,ecx dec edx std ; destination >= source, copy downwards move1: add eax,dp ; absolute destination add edx,dp ; absolute source push edi ; save edi push esi ; save esi push edx ; load source pop esi push eax ; load dest pop edi push ds ; same seg .. pop es ; .. for source and dest rep movsb ; copy address units ... this can be optimized later pop esi ; restore esi pop edi ; restore edi cld ; !!!***!!! VERY IMPORTANT because NEST depends on it !!!***!!! move2: next ;--( Comparisons ) ; Can't use our name header macros with this one! linkme flinkptr countcell 2 db '0',0,'<',0 ; x -- flag align 4 ; CORE fw_ZEROLT: docode mov eax,[esp] shl eax,1 sbb edx,edx mov [esp],edx next fnamemanque <0=> ; x -- flag fw_ZEROEQ: docode ; CORE mov eax,[esp] and eax,eax je zeroeq1 mov DWORD PTR [esp],FALSE next zeroeq1: mov DWORD PTR [esp],TRUE next ; Can't use our name header macros with this one! linkme flinkptr countcell 3 db '0',0,'<',0,'>',0 ; x -- flag align 4 ; CORE EXT fw_ZERONE: docode mov eax,[esp] and eax,eax jne zeroeq1 ; reuse code above mov DWORD PTR [esp],FALSE next ; Can't use our name header macros with this one! linkme flinkptr countcell 2 db '0',0,'>',0 ; x -- flag align 4 ; CORE EXT fw_ZEROGT: ctok NEST ctok DUP ; -- x x ctok ZEROLT ; -- x flag ctok SWAP ; -- flag x ctok ZEROEQ ; -- flag1 flag2 ctok OR ; -- flag ctok ZEROEQ ; -- flag' ctok UNNEST ; Can't use our name header macros with this one! linkme flinkptr countcell 1 db '<',0 ; n1 n2 -- flag align 4 ; CORE fw_LESS: docode pop eax mov edx,[esp] cmp edx,eax jl less1 mov DWORD PTR [esp],FALSE next less1: mov DWORD PTR [esp],TRUE next ; Can't use our name header macros with this one! linkme flinkptr countcell 2 db 'U',0,'<',0 ; u1 u2 -- flag align 4 ; CORE fw_U_LESS: docode pop eax mov edx,[esp] cmp edx,eax jb less1 ; we can re-use code from above mov DWORD PTR [esp],FALSE next ; Can't use our name header macros with this one! linkme nlinkptr countcell 3 db 'U',0,'D',0,'<',0 ; ud1 ud2 -- flag align 4 ; Not in standard fw_UD_LESS: docode pop edx ; ud2h pop eax ; ud2l pop ecx ; ud1h cmp edx,ecx ; ud2h ja udless ; if ud2h > ud1h, TRUE jb nudless ; if ud2h < ud1h, FALSE cmp eax,[esp] ; they were equal, try low half ja udless ; now if ud2l > ud1l, TRUE nudless: ; ud2l =< ud1l, FALSE mov DWORD PTR [esp],FALSE next udless: mov DWORD PTR [esp],TRUE next ; Can't use our name header macros with this one! linkme flinkptr countcell 2 db 'D',0,'=',0 ; xd1 xd2 -- flag align 4 ; DOUBLE fw_DEQUAL: docode pop edx ; d2h pop eax ; d2l pop ecx ; d1h cmp edx,ecx ; d2h == d1h? jne dnequal ; no cmp eax,[esp] ; yes, try lower jne dnequal ; d2l != d1l mov DWORD PTR [esp],TRUE ; d2l == d1l next dnequal: mov DWORD PTR [esp],FALSE next ; Can't use our name header macros with this one! linkme flinkptr countcell 1 db '=',0 ; x1 x2 -- flag align 4 ; CORE fw_EQUAL: docode pop eax mov edx,[esp] cmp eax,edx je equal1 mov DWORD PTR [esp],FALSE next equal1: mov DWORD PTR [esp],TRUE next ; Can't use our name header macros with this one! linkme flinkptr countcell 2 db '<',0,'>',0 ; x1 x2 -- flag align 4 ; CORE EXT fw_NEQUAL: docode pop eax mov edx,[esp] cmp eax,edx jne equal1 ; re-using above code mov DWORD PTR [esp],FALSE next ; Can't use our name header macros with this one! linkme flinkptr countcell 1 db '>',0 ; n1 n2 -- flag align 4 ; CORE fw_GREATER: docode pop eax mov edx,[esp] cmp edx,eax ja greater1 mov DWORD PTR [esp],FALSE next greater1: mov DWORD PTR [esp],TRUE next fname <MAX> ; n1 n2 -- n3 docode ; CORE pop eax pop edx cmp eax,edx jl f_max1 push eax next f_max1: push edx next fname <MIN> ; n1 n2 -- n3 docode ; CORE pop edx pop eax cmp eax,edx ja f_max1 ; reuse code from above push eax next fname <WITHIN> ; n|u1 n|u2 n|u3 -- flag ctok NEST ; CORE EXT ctok OVER ctok MINUS ; -- n1 n2 diffn3n2 ctok TO_R ; -- n1 n2 R: -- diffn3n2 ctok MINUS ; -- diffn1n2 R: -- diffn3n2 ctok R_FROM ; -- diffn1n2 diffn3n2 R: -- ctok U_LESS ; -- flag ctok UNNEST ;--( Integer Math ) fnamemanque <1+> ; n|u1 -- n|u2 fw_ONE_PLUS: docode add DWORD PTR [esp],1 next fnamemanque <1-> ; n|u1 -- n|u2 fw_ONE_MINUS: docode sub DWORD PTR [esp],1 next fname <ABS> ; n -- u ctok NEST ; CORE ctok DUP ctok ZEROLT ; -- n flag compif abs1 ctok NEGATE abs1: ctok UNNEST ; -- _n_ fname <DABS> ; d -- ud ctok NEST ; DOUBLE ctok DUP ctok ZEROLT ; -- d flag compif dabs1 ctok DNEGATE dabs1: ctok UNNEST ; -- _d_ ; Can't use our name header macros with this one! linkme flinkptr countcell 3 db 'S',0,'>',0,'D',0 ; n1 -- d1 align 4 ; CORE fw_S_TO_D: docode mov eax,[esp] cdq push edx next fname <NEGATE> ; n1 -- n2 docode ; CORE mov eax,[esp] neg eax mov [esp],eax next fname <DNEGATE> ; d1 -- d2 docode ; DOUBLE xor eax,eax xor edx,edx sub eax,cell[esp] sbb edx,[esp] mov cell[esp],eax mov [esp],edx next fnamemanque <+> ; n|u1 n|u2 -- n|u3 fw_PLUS: ; CORE docode pop eax add [esp],eax next fnamemanque <D+> ; ud|d1 ud|d2 -- ud|d3 fw_D_PLUS: ; DOUBLE docode pop edx ; d2h pop eax ; d2l add cell[esp],eax ; d1l+d2l adc [esp],edx ; d1h+d2h+carry next fnamemanque <-> ; n|u1 n|u2 -- n|u3 fw_MINUS: ; CORE docode pop eax sub [esp],eax next fnamemanque <D-> ; ud|d1 ud|d2 -- ud|d3 fw_D_MINUS: ; DOUBLE docode pop edx ; d2h pop eax ; d2l sub cell[esp],eax ; d1l-d2l sbb [esp],edx ; d1h-d2h-borrow next fnamemanque <*> ; n|u1 n|u2 -- n|u3 fw_STAR: ; CORE docode pop eax imul DWORD PTR[esp] mov [esp],eax next fnamemanque </> ; n1 n2 -- n3 fw_SLASH: ; CORE docode pop ecx ; n2 pop eax ; n1 xor edx,edx ; high order for div idiv ecx ; n1 / n2 push eax ; quotient next ; -- n3 fnamemanque </MOD> ; n1 n2 -- n3 n4 fw_SLMOD: ; CORE docode pop ecx ; n2 pop eax ; n1 xor edx,edx ; high order for div idiv ecx ; n1 / n2 push edx ; remainder push eax ; quotient next ; -- n3 n4 fname <MOD> ; n1 n2 -- n3 ctok NEST ctok SLMOD ctok DROP ctok UNNEST fnamemanque <*/> ; n1 n2 n3 -- n4 fw_STARSL: ; CORE docode pop ecx ; n3 pop edx ; n2 pop eax ; n1 imul edx ; n1 * n2 idiv ecx ; intermediate / n3 push eax ; quotient next ; -- n4 fnamemanque <*/MOD> ; n1 n2 n3 -- n4 n5 fw_STARSLMOD: ; CORE docode pop ecx ; n3 pop edx ; n2 pop eax ; n1 imul edx ; n1 * n2 idiv ecx ; intermediate / n3 push edx ; remainder push eax ; quotient next ; -- n4 n5 nnamemanque <DUM/MOD> ; d1 n1 -- n2 d2 fw_DUMSLMOD: ; not in Standard ctok NEST ctok TO_R ; -- d1l d1h R: -- n1 literal 0 ; -- d1l d1h 0 R: -- n1 ctok R_FETCH ; -- d1l d1h 0 n1 R: -- n1 ctok UMSLMOD ; -- d1l r1 q1 R: -- n1 ctok R_FROM ; -- d1l r1 q1 n1 R: -- ctok SWAP ; -- d1l r1 n1 q1 R: -- ctok TO_R ; -- d1l r1 n1 R: -- d2h ctok UMSLMOD ; -- r2 q2 R: -- d2h ctok R_FROM ; -- n2 d2 ctok UNNEST ; -- n2 d2 fnamemanque <FM/MOD> ; d1 n1 -- n2 n3 fw_FMSLMOD: ; CORE ctok NEST ctok DUP ; -- d1 n1 ctok TO_R ; -- d1 n1 R: -- n1 ctok ZEROLT ; -- d1 flag R: -- n1 compif fmslmod1 ctok DNEGATE fmslmod1: ctok S_TO_D ; -- d1l d1hl d1hh R: -- n1 ctok R_FETCH ; -- d1l d1hl d1hh n1 R: -- n1 ctok ABS ; -- d1l d1hl d1hh _n1_ R: -- n1 ctok AND ; -- d1l d1hl d1hh _n1_ R: -- n1 ctok PLUS ; -- d1l intermed R: -- n1 ctok R_FETCH ; -- d1l intermed n1 R: -- n1 ctok ABS ; -- d1l intermed _n1_ R: -- n1 ctok UMSLMOD ; -- n2' n3 R: -- n1 ctok SWAP ; -- n3 n2' R: -- n1 ctok R_FROM ; -- n3 n2' n1 R: -- ctok ZEROLT ; -- n3 n2' flag compif fmslmod2 ctok NEGATE ; -- n3 n2 fmslmod2: ctok SWAP ; -- n2 n3 ctok UNNEST fnamemanque <SM/REM> ; d1 n1 -- n2 n3 fw_SMSLREM: ; CORE docode pop ecx ; u1 pop edx ; udh pop eax ; udl idiv ecx push edx ; remainder push eax ; quotient next ; -- u2 u3 fnamemanque <UM*> ; u1 u2 -- ud fw_UMSTAR: ; CORE docode mov eax,cell[esp] ; u1 mul DWORD PTR [esp] ; u1*u2 mov cell[esp],eax ; udl mov [esp],edx ; udh next ; -- ud fnamemanque <UM/MOD> ; ud u1 -- u2 u3) fw_UMSLMOD: ; CORE docode pop ecx ; u1 pop edx ; udh pop eax ; udl div ecx push edx ; remainder push eax ; quotient next ; -- u2 u3 fnamemanque <M*> ; n1 n2 -- d fw_MSTAR: ; CORE docode mov eax,cell[esp] ; n1 imul DWORD PTR [esp] ; n1*n2 mov cell[esp],eax ; dl mov [esp],edx ; dh next ; -- ud nnamemanque <UD*U> ; ud1 u1 -- ud2 fw_UDSTARU: ; not in standard docode pop ecx ; u1 pop eax ; ud1h mul ecx ; produce extended ud2h mov edx,ecx ; discard upper dword of ud2he, move multiplier into edx mov ecx,eax ; save lower portion of ud2he in ecx pop eax ; ud1l mul edx ; ud2l in eax push eax ; return ud2l add edx,ecx ; form ud2h push edx ; return ud2h next ; -- ud2 ;--( Bit Operators ) fname <TRUE> ; -- flag ctok DOCONST ; CORE EXT dd TRUE fname <FALSE> ; -- flag ctok DOCONST ; CORE EXT dd FALSE fname <AND> ; x1 x2 -- x3 docode ; CORE pop eax and [esp],eax next fname <OR> ; x1 x2 -- x3 docode ; CORE pop eax or [esp],eax next fname <XOR> ; x1 x2 -- x3 docode ; CORE pop eax xor [esp],eax next fname <INVERT> ; x1 -- x2 docode ; CORE mov eax,[esp] not eax mov [esp],eax next fnamemanque <2*> ; x1 -- x2 fw_TWO_STAR: ; CORE docode mov eax,[esp] shl eax,1 mov [esp],eax next fnamemanque <2/> ; x1 -- x2 fw_TWO_SLASH: ; CORE docode mov eax,[esp] shr eax,1 mov [esp],eax next fname <LSHIFT> ; x1 u -- x2 docode ; CORE pop ecx mov eax,[esp] shl eax,cl mov [esp],eax next fname <RSHIFT> ; x1 u -- x2 docode ; CORE pop ecx mov eax,[esp] shr eax,cl mov [esp],eax next ;--( Characters ) fname <BL> ; -- char ctok DOCONST ; CORE dd 20H fname <CHAR> ; -- char ctok NEST ; CORE ctok BL ctok WORD ctok CHAR_PLUS ctok C_FETCH ctok UNNEST finamemanque <[CHAR]> ; -- Execution: -- char fw_BRACHETCHAR: ctok NEST ; CORE ctok CHAR ctok LITERAL ctok UNNEST fname <SPACE> ; -- ctok NEST ; CORE ctok BL ctok EMIT ctok UNNEST fname <SPACES> ; n -- ctok NEST ; CORE literal 0 ctok MAX literal 0 compqdo spaces1 spaces0: ctok SPACE comploop spaces0 spaces1: ctok UNNEST fnamemanque <CHAR+> ; c-addr1 -- c-addr2 fw_CHAR_PLUS: ; CORE docode add DWORD PTR [esp],tchar next fname <CHARS> ; n1 -- n2 ctok NEST ; CORE literal tchar ctok STAR ctok UNNEST fname <FILL> ; c-addr u char -- docode ; CORE pop eax ; char pop ecx ; count pop edx ; dest jecxz fill_done ; zero count? we're done before we start add edx,dp ; abs addr push ds pop es ; same seg, this is default, but user might have changed it in a CODE word push edi ; save edi push edx pop edi ; load destination rep stosw ; store char pop edi ; restore edi fill_done: next ;--( Strings ) fnamemanque </STRING> ; c-addr1 u1 n -- c-addr2 u2 fw_SLSTRING: ctok NEST ctok ROT ; -- u1 n c-a1 ctok OVER ; -- u1 n c-a1 n ctok CHARS ; -- u1 n c-a1 nbytes ctok PLUS ; -- u1 n c-a2 ctok NEGROT ; -- c-a2 u1 n ctok MINUS ; -- c-a2 u2 ctok UNNEST fname <CMOVE> ; c-addr1 c-addr2 u -- ctok NEST ; STRING ctok QDUP ; -- c-addr1 c-addr2 [ u u | 0 ] ctok ZEROEQ compif cmove1 ctok TWO_DROP ; -- ctok EXIT cmove1: literal 0 compdo cmove3 cmove2: ctok OVER ; -- c-addr1 c-addr2 c-addr1 ctok C_FETCH ; -- c-addr1 c-addr2 char ctok OVER ; -- c-addr1 c-addr2 char c-addr2 ctok C_STORE ; -- c-addr1 c-addr2 ctok CHAR_PLUS ; -- c-addr1 c-addr2' ctok SWAP ctok CHAR_PLUS ; -- c-addr2' c-addr1' ctok SWAP ; -- c-addr1' c-addr2' comploop cmove2 cmove3: ctok TWO_DROP ctok UNNEST ; -- ; Can't use our name header macros with this one! linkme flinkptr countcell 6 db 'C',0,'M',0,'O',0,'V',0,'E',0,'>',0 ; c-addr1 c-addr2 u -- align 4 ; STRING fw_CMOVER: ctok NEST ctok QDUP ; -- c-addr1 c-addr2 [ u u | 0 ] ctok ZEROEQ compif cmover1 ctok TWO_DROP ; -- ctok EXIT cmover1: ctok DUP ; -- c-addr1 c-addr2 u u ctok TO_R ; -- c-addr1 c-addr2 u R: -- u ctok CHARS ; -- c-addr1 c-addr2 u' R: -- u ctok TUCK ; -- c-addr1 u' c-addr2 u' R: -- u ctok PLUS ; -- c-addr1 u' c-addr2' R: -- u ctok TO_R ; -- c-addr1 u' R: -- u c-addr2' ctok PLUS ; -- c-addr1' R: -- u c-addr2' ctok R_FROM ctok R_FROM ; -- c-addr1' c-addr2' u literal 0 compdo cmover3 cmover2: literal tchar ; -- c-addr1' c-addr2' n ctok MINUS ; -- c-addr1' c-addr2'' ctok SWAP literal tchar ctok MINUS ; -- c-addr2'' c-addr1'' ctok SWAP ; -- c-addr1'' c-addr2'' ctok OVER ; -- c-addr1'' c-addr2'' c-addr1'' ctok C_FETCH ; -- c-addr1'' c-addr2'' char ctok OVER ; -- c-addr1'' c-addr2'' char c-addr2'' ctok C_STORE ; -- c-addr1'' c-addr2'' comploop cmover2 cmover3: ctok TWO_DROP ; -- ctok UNNEST fname <COUNT> ; c-addr1 -- c-addr2 u docode mov eax,[esp] xor edx,edx mov dx,[eax][dp] add eax,tchar mov [esp],eax push edx next fname <COMPARE> ; c-addr1 u1 c-addr2 u2 -- n docode ; STRING pop ecx ; u2 pop edx ; c-addr2 add edx,dp ; convert to abs addr pop eax ; u1 cmp ecx,eax ; counts equal? je compare_e ; yes, continue further on jl compare_u1 ; if u2 (in ecx) is lesser, continue further on mov ecx,eax ; u2 > u1 mov eax,[esp] ; c-addr1 add eax,dp ; convert to abs addr push esi ; preserve push edi ; preserve push ds ; pop es ; set ES, this is probably redundant in view of system requirements mov esi,eax ; c-addr1 mov edi,edx ; c-addr2 cld ; direction upwards repe cmpsw ; unicode is 2-byte chars je compare_neg1 ; all matched, u2 > u1 mov ax,[esi] cmp ax,[edi] ; compare non-match c-addr1 char to c-addr2 char jl compare_neg1 ; c-addr1 char is less jmp SHORT compare_1 ; c-addr2 char is less compare_u1: ; u1 > u2 mov eax,[esp] ; c-addr1 add eax,dp ; convert to abs addr push esi ; preserve push edi ; preserve push ds ; pop es ; set ES, this is probably redundant in view of system requirements mov esi,eax ; c-addr1 mov edi,edx ; c-addr2 cld ; direction upwards repe cmpsw ; unicode is 2-byte chars je compare_1 ; all matched, u1 > u2 mov ax,[esi] cmp ax,[edi] ; compare non-match c-addr1 char to c-addr2 char jl compare_neg1 ; c-addr1 char is less jmp SHORT compare_1 ; c-addr2 char is less compare_e: ; u1 = u2 mov eax,[esp] ; c-addr1 add eax,dp ; convert to abs addr push esi ; preserve push edi ; preserve push ds ; pop es ; set ES, this is probably redundant in view of system requirements mov esi,eax ; c-addr1 mov edi,edx ; c-addr2 cld ; direction upwards repe cmpsw ; unicode is 2-byte chars je compare_0 ; all matched mov ax,[esi] cmp ax,[edi] ; compare non-match c-addr1 char to c-addr2 char jl compare_neg1 ; c-addr1 char is less jmp SHORT compare_1 ; c-addr2 char is less compare_0: xor eax,eax mov 2*cell[esp],eax ; strings are equal and u1 = u2 jmp SHORT compare_done compare_1: mov eax,1 mov 2*cell[esp],eax ; char at first non-match in c-addr1 .gt. corresponding in c-addr2 jmp SHORT compare_done ; or strings equal, and u1 > u2 compare_neg1: mov eax,-1 mov 2*cell[esp],eax ; char at first non-match in c-addr1 .lt. corresponding in c-addr2 jmp SHORT compare_done ; or strings equal, and u1 < u2 compare_done: pop edi pop esi next nname <PLACE> ; c-addr1 u c-addr2 ctok NEST ; Not in Standard ctok TWO_DUP ; c-addr1 u c-addr2 u c-addr2 ctok C_STORE ; c-addr1 u c-addr2 ctok CHAR_PLUS ; c-addr1 u c-addr2' ctok SWAP ; c-addr1 c-addr2' u ctok CHARS ; c-addr1 c-addr2' u' ctok MOVE ; -- ctok UNNEST nname <SKIP> ; ( c-addr1 u1 char --- c-addr2 u2) docode ; Not in standard, skip to first non-match pop eax ; -- c-addr u1 pop ecx ; -- c-addr1 u count to iteration register pop edx ; -- address of start of string add edx,dp ; -- add offset to base of data region, forming absolute address push edi ; -- edi preserve edi push ds ; -- edi ds pop es ; -- edi load es from ds push edx ; -- edi abs-addr1 pop edi ; -- edi load edi cld ; ascending search repe scasw ; search for non-match je skip_fail ; zero is set if no non-match was found pop eax ; -- saved di push edi ; -- abs-addr2 address after end of string, abs pop edx ; -- get it back sub edx,tchar ; -- move it back to point to non-match char sub edx,dp ; -- convert back to data-relative address push edx ; -- c-addr2 return it inc ecx ; -- c-addr2 back count up to match point push ecx ; -- c-addr2 u2 return count of remainder of string push eax ; -- c-addr2 u2 di pop edi ; -- c-addr2 u2 restore edi next skip_fail: pop eax ; saved edi push edi ; address after end of string, abs pop edx ; get it back sub edx,dp ; convert back to data-relative address push edx ; return it push ecx ; return zero which will be in ecx in this branch push eax ; that ol' saved di pop edi ; restore, -- c-addr2 u2 next nname <SCAN> ; ( c-addr1 u1 char --- c-addr2 u2) docode ; Not in Standard, point to head of substring c-addr2 u2 where char first found pop eax ; char pop ecx ; count to iteration register pop edx ; address of start of string add edx,dp ; add offset to base of data seg push edi ; save edi push ds pop es ; load es from ds push edx pop edi ; load edi cld ; ascending search repne scasw ; search for match jne scan_fail ; zero is set if char was ever found pop eax ; saved edi push edi ; address after end of string, abs pop edx ; get it back sub edx,tchar ; move it back to match char sub edx,dp ; convert back to data-relative address push edx ; return it inc ecx ; back count up to match point push ecx ; return count of remainder of string push eax ; that ol' saved edi pop edi ; restore, -- c-addr2 u2 next scan_fail: pop eax ; saved edi push edi ; address after end of string, abs pop edx ; get it back sub edx,dp ; convert back to data-relative address push edx ; return it push ecx ; return zero which will be in ecx in this branch push eax ; that ol' saved edi pop edi ; restore, -- c-addr2 u2 next fnamemanque <-TRAILING> ; c-addr1 u1 -- c-addr1 u2 fw_DASH_TRAILING: ; STRING docode mov ecx,[esp] ; count mov edx,cell[esp] ; string address add edx,ecx ; do this twice to handle wide character size add edx,ecx ; point past end of string sub edx,tchar ; point to last character in string add edx,dp ; absolute address mov ax,20h ; blank push edi ; preserve edi push edx ; end-of-string abs address pop edi ; load edi push ds pop es ; same seg, probably redundant std ; backwards search repe scasw ; seek non-match with char je none_trailing ; no non-blanks pop edi ; restore edi inc cx ; adjust count to point back to end of string mov [esp],ecx ; new count cld ; !!!***!!! important, NEXT won't work unless direction flag set this way next none_trailing: ; no non-blanks at all pop edi ; restore edi mov DWORD PTR [esp],FALSE ; zero count cld ; !!!***!!! important, NEXT won't work unless direction flag set this way next finame <SLITERAL> ; c-addr1 u Execution: -- c-addr2 u ctok NEST ; STRING ctok STATEABORT ctok ALIGN ctok DUP ; -- c-addr1 u u ctok HERE ; -- c-addr1 u u here ctok TWO_SWAP ; -- u here c-addr1 u ctok HERE ; -- u here c-addr1 u here ctok PLACE ; -- u here ctok DOLIT ctok DOSQUOTE ; -- u here xt ctok COMPCOMMA ctok COMPCOMMA ; -- u ctok ONE_PLUS ; -- u' account for count character ctok CHARS ; -- chars ctok ALLOT ; -- ctok UNNEST ; Can't use our name header macros with this one! linkme flinkptr countcell <2 or immedMask> db 'S',0,'"',0 ; Interp: "ccc<"> -- c-addr u Compile: "ccc<"> -- Execute: c-addr u align 4 ; FILE fw_S_QUOTE: ctok NEST charlit '"' ; -- char ctok PARSE ; -- c-addr u ctok STATE ; -- c-addr u a-addr ctok FETCH ; -- c-addr u flag compif s_quote1 ; are we compiling? ctok ALIGN ; for good luck -- maybe this should be removed ctok HERE ; -- c-addr1 u c-addr2 ctok DUP ; -- c-addr1 u c-addr2 c-addr2 ctok TO_R ; -- c-addr1 u c-addr2 R: -- c-addr2 ctok OVER ; -- c-addr1 u c-addr2 u R: -- c-addr2 ctok ONE_PLUS ; -- c-addr1 u c-addr2 u' R: -- c-addr2 ctok CHARS ; -- c-addr1 u c-addr2 chars R: -- c-addr2 ctok ALLOT ; -- c-addr1 u c-addr2 R: -- c-addr2 ctok PLACE ; -- R: -- c-addr2 literal 0 ctok CCOMMA ; -- null pad ctok DOLIT ctok DOSQUOTE ; -- xt R: -- c-addr2 ctok COMPCOMMA ; -- R: -- c-addr2 ctok R_FROM ; -- c-addr2 R: -- ctok COMPCOMMA ; -- ctok EXIT s_quote1: literal stringBuffer ; -- c-addr1 u c-addr2 ctok PLACE ; -- literal stringBuffer ; -- c-addr2 ctok COUNT ; -- c-addr2 u ctok TWO_DUP ctok CHARS ctok PLUS literal 0 ctok SWAP ctok C_STORE ; append null terminator ctok UNNEST ; Can't use our name header macros with this one! linkme flinkptr countcell <2 or immedMask> db '.',0,'"',0 ; Interp: -- c-addr u Compile -- align 4 ; CORE fw_DOT_QUOTE: ctok NEST ctok STATEABORT ctok DP ctok FETCH ; -- dictionary-pointer ctok S_QUOTE ; -- dp S" has stored string and embedded execution engine ctok DOLIT ctok DODOTQUOTE ctok SWAP ; -- xt dp ctok CODETODATA ctok STORE ; -- overwrite S" exe engine with ." exe engine ctok UNNEST fname <PAD> ; -- c-addr ctok DOCONST ; CORE EXT dd tickpad ;--( Number Conversion ) fname <BASE> ; a-addr ctok DOCONST ; CORE dd var_base fname <DECIMAL> ; -- ctok NEST ; CORE literal 10 ctok BASE ctok STORE ctok UNNEST fname <HEX> ; -- ctok NEST ; CORE literal 16 ctok BASE ctok STORE ctok UNNEST fname <HLD> ; a-addr ctok DOCONST ; Implementation detail dd var_hld fname <HOLD> ; char -- ctok NEST ; CORE literal -1 ctok CHARS ctok HLD ctok PL_STORE ; predecrement offset pointer which was set by <# ctok HLD ctok FETCH ctok C_STORE ; store character in numeric format buffer ctok UNNEST ; Is char a digit in base n? nname <DIGIT> ; char n1 -- n2 true | char false docode ; Not in Standard pop edx ; base pop eax ; char mov ecx,eax ; save copy of char sub ax,'0' ; is char >= '0' jb not_digit ; if not, jump not_digit cmp ax,9 ; is char <= 9 jbe digit1 ; yes, jump to digit_1 cmp ax,'A'-'0' ; no, see if it's an alpha number jb not_digit ; it ain't, jump away sub ax,'A'-'0'-10 ; it is, subtract offset of that portion of char set to make correct digit digit1: cmp ax,dx ; now compare resultant number to base jnb not_digit ; it ain't a digit if it ain't below the value of the base push eax ; it is a digit, push push TRUE ; TRUE for success next not_digit: push ecx ; char xor eax,eax ; false, failure push eax next nname <DPL> ; -- a-addr ctok DOCONST ; Not in Standard dd var_dpl nname <NUMBER> ; c-addr1 u1 -- d TRUE | x x FALSE ctok NEST ; Not in Standard ctok TRUE ctok DPL ctok STORE ; indicate no dot in number input as default ctok OVER ; -- c-a1 u1 c-a1 ctok C_FETCH ; -- c-a1 u1 char charlit '-' ; -- c-a1 u1 char1 char2 ctok EQUAL ; -- c-a1 u1 flag ctok DUP ; -- c-a1 u1 flag flag ctok TO_R ; -- c-a1 u1 flag flag R: -- flag save negative flag compif number1 ; was there a prepended negative sign? ctok ONE_MINUS ; -- c-a1 u1' R: -- flag yes, dec count ctok SWAP ctok CHAR_PLUS ; -- u1' c-a1' R: -- flag advance address ctok SWAP ; -- c-a1' u1' R: -- flag number1: ctok FALSE ctok FALSE ; -- c-a1' u1' ud R: -- flag ctok TWO_SWAP ; -- ud c-a1' u1' R: -- flag number2: ctok TO_NUMBER ; -- ud c-a2 u2 R: -- flag ctok QDUP ; -- ud c-a2 [ u2 u2 | 0 ] R: -- flag compif number_success ; did number conversion complete leave non-zero count of chars left? ctok OVER ; -- ud c-a2 u2 c-a2 R: -- flag ctok C_FETCH ; -- ud c-a2 u2 char R: -- flag charlit '.' ; -- ud c-a2 u2 char1 char2 R: -- flag ctok EQUAL ; -- ud c-a2 u2 flag R: -- flag compif number_fail ; was the character which stopped the conversion a "dot"? ctok DUP ; -- ud c-a2 u2 u2 R: -- flag ctok ONE_MINUS ; -- ud c-a2 u2 u2' R: -- flag ctok DPL ; -- ud c-a2 u2 u2' a-addr R: -- flag ; right-justified count to dot-place-marker ctok STORE ; -- ud c-a2 u2 R: -- flag ctok ONE_MINUS ; -- ud c-a2 u2' R: -- flag ctok SWAP ; -- ud u2' c-a2 R: -- flag ctok CHAR_PLUS ; -- ud u2' c-a2' R: -- flag ctok SWAP ; -- ud c-a2' u2' R: -- flag ctok DUP ; -- ud c-a2' u2' R: -- flag ctok DOUNTILNOT ; more chars? try it some more! This allows multiple dots in a number ... sounds ok dd number2 ; otherwise, we're done if parsing the "dot" exhausted the string ctok DROP ; -- ud c-a2' R: -- flag compelse number_success number_fail: ; -- ud c-a u R: -- flag ctok TWO_DROP ; -- ud R: -- flag ctok FALSE ; -- ud 0 R: -- flag ctok R_FROM ; -- ud 0 flag R: -- ctok DROP ; -- ud 0 ctok EXIT ; -- x x 0 number_success: ; -- ud c-addr R: -- flag ctok DROP ; -- ud R: -- flag ctok R_FROM ; -- ud flag R: -- compif number_done ; did we mark this negative? ctok DNEGATE ; -- d number_done: ctok TRUE ; -- d true ctok UNNEST ; Can't use our name header macros with this one! linkme flinkptr countcell 7 db '>',0,'N',0,'U',0,'M',0,'B',0,'E',0,'R',0 ; ud1 c-addr1 u1 -- ud2 c-addr2 u2 fw_TO_NUMBER: ctok NEST tonum1: ctok DUP ; BEGIN -- ud1 c-addr1 u1 u1 compif tonum4 ; WHILE ctok SWAP ; -- ud1 u1 c-addr1 ctok COUNT ; -- ud1 u1 c-addr char ctok BASE ; -- ud1 u1 c-addr char a-addr ctok FETCH ; -- ud1 u1 c-addr char n ctok DIGIT ; -- ud1 u1 c-addr n flag compif tonum2 ; if it's a digit ctok TO_R ; -- ud1 u1 c-addr R: -- n ctok TWO_SWAP ; -- u1 c-addr ud1 R: -- n ctok BASE ctok FETCH ; -- u1 c-addr ud1 n R: -- n ctok UDSTARU ; -- u1 c-addr ud R: -- n ctok R_FROM literal 0 ; -- u1 c-addr ud "udx" R: -- ctok D_PLUS ; -- u1 c-addr ud' ctok TWO_SWAP ; -- ud' u1 c-addr ctok SWAP ; -- ud2 c-addr u1 compelse tonum3 ; ELSE tonum2: ctok DROP ; -- ud2 u2 c-addr literal tchar ctok MINUS ; -- ud2 u2 c-addr2 ctok SWAP ; -- ud2 c-addr2 u2 ctok EXIT ; THEN tonum3: ctok ONE_MINUS ; -- ud c-addr u compelse tonum1 ; REPEAT tonum4: ctok UNNEST ; -- ud2 c-addr2 u2 ; Can't use our name header macros with this one! linkme flinkptr countcell 2 db '<',0,'#',0 ; -- align 4 ; CORE fw_LSHARP: ctok NEST literal ticknumend ctok HLD ctok STORE ; set up pointer to numeric output string format buffer ctok UNNEST fnamemanque <#> ; ud1 -- ud2 fw_SHARP: ctok NEST ctok BASE ctok FETCH ctok DUMSLMOD ; -- r ud' ctok ROT ctok DUP literal 10 ctok LESS ; -- ud' r flag ; is this within the numeric Unicode chars? compif sharp1 ctok DOLIT db '0',0,0,0 ; -- ud' r char ; yes, we'll need to add its number to the char '0' compelse sharp2 sharp1: literal 'A'-10 ; -- ud' r char ; no we'll need to add its number to an offset from 'A' sharp2: ctok PLUS ; -- ud' char' ctok HOLD ; -- ud' ; store char ctok UNNEST fnamemanque <#S> ; ud1 -- ud2 fw_SHARPS: ctok NEST sharps: ctok SHARP ; -- ud' loop converting chars ctok TWO_DUP ; -- ud' ud' ctok OR ; -- ud' flag ctok DOUNTILNOT ; -- ud' loop until it's 0.0 dd sharps ctok UNNEST ; Can't use our name header macros with this one! linkme flinkptr countcell 2 db '#',0,'>',0 ; ud -- c-addr u align 4 ; CORE fw_SHARPR: ctok NEST ctok TWO_DROP ; -- discard what's left of double which was to be formatted ctok HLD ctok FETCH ; -- c-addr literal ticknumend ; -- c-addr1 c-addr2 ctok OVER ; -- c-addr1 c-addr2 ctok MINUS ; -- c-addr1 n literal 1 ctok CHARS ; -- c-addr1 n sizeofchar address diff has to be divided by char size ctok SLASH ; -- c-addr u ctok UNNEST ;--( I/O ) fname <CR> ; -- ctok NEST ; CORE literal 0DH ctok EMIT literal 0AH ctok EMIT ctok UNNEST fname <SIGN> ; n -- ctok NEST ; CORE ctok ZEROLT compif sign1 charlit '-' ctok HOLD sign1: ctok UNNEST fnamemanque <.> ; n -- fw_DOT: ctok NEST ; CORE ctok PDOT ctok TYPE ; -- ctok BL ctok EMIT ctok UNNEST fnamemanque <.R> ; n1 n2 -- fw_DOT_R: ctok NEST ; CORE EXT ctok SWAP ; -- n2 n1 ctok PDOT ; -- n2 c-addr u ctok ROT ; -- c-addr u n2 ctok OVER ; -- c-addr u n2 u ctok MINUS ; -- c-addr u1 u2 literal 0 ctok MAX ; -- c-addr u1 u2' ctok SPACES ; -- c-addr u ctok TYPE ; -- ctok UNNEST znamemanque <(.)> ; n -- c-addr u fw_PDOT: ctok NEST ctok DUP ; -- n n ctok ABS ; -- n _n_ ctok S_TO_D ; -- n d ctok LSHARP ; -- n d ctok SHARPS ; -- n d' ctok ROT ; -- d' n ctok SIGN ; -- d ctok SHARPR ; -- c-addr u ctok UNNEST fnamemanque <D.> ; d -- fw_D_DOT: ctok NEST ; CORE ctok TUCK ; -- dh d ctok DABS ; -- dh _d_ ctok LSHARP ; -- dh _d_ ctok SHARPS ; -- dh d' ctok ROT ; -- d' dh ctok SIGN ; -- d' ctok SHARPR ; -- c-addr u ctok TYPE ; -- ctok BL ctok EMIT ctok UNNEST fnamemanque <U.> ; u -- fw_U_DOT: ; CORE ctok NEST literal 0 ctok UD_DOT ctok UNNEST nnamemanque <UD.> ; ud -- fw_UD_DOT: ; Not in Standard ctok NEST ctok LSHARP ctok SHARPS ctok SHARPR ctok TYPE ctok BL ctok EMIT ctok UNNEST fnamemanque <.S> ; i*x -- i*x fw_DOT_S: ; CORE EXT ctok NEST ctok DEPTH literal 0 ctok MAX ctok DUP literal 0 compqdo dot_s1 dot_s0: ctok DUP ctok I ctok MINUS ctok PICK ctok U_DOT comploop dot_s0 dot_s1: ctok DROP ctok UNNEST zname <DEBDOTS> ; i*j char -- i*j ctok NEST ctok EMIT ctok SPACE ctok DOT_S ctok KEY ctok DROP ctok CR ctok UNNEST fname <KEY> ; -- char docode ; CORE xor ecx,ecx ; clear character holder lea eax,[dp+conMode] ; in order to preserve con mode stdCall _GetConsoleMode,<[dp+stdIn],eax> ; let's find out what it is and eax,eax ; success is "C" TRUE jne key2 ; if GetConsoleMode succeeds, continue mov eax,UniNotAChar ; on failure, push invalid char push eax jmp doLastErr ; return to NEXT via doLastErr key2: stdCall _SetConsoleMode,<[dp+stdIn],0> ; set no echo, no line input, no window/mouse/processed and eax,eax ; success is "C" TRUE jne key3 ; if SetConsoleMode succeeds, continue mov eax,UniNotAChar ; on failure, push invalid char push eax jmp doLastErr ; return to NEXT via doLastErr key3: stdCall _ReadConsoleW,<[dp+stdIn],OFFSET FLAT:lastReadConW,1,OFFSET FLAT:numRead,0> ; get a char and eax,eax ; "C" TRUE is success je key4 ; on failure, get error code mov DWORD PTR lastError[dp],TRUE ; success, return TRUE, no Windows error code has all bits set cmp DWORD PTR numRead,0 ; did we get any? je key3 ; loop waiting xor ecx,ecx ; clear for character mov cx,WORD PTR lastReadConW ; retrieve char, ecx ostensibly clear for now push ecx ; push to stack mov eax,conMode[dp] ; get saved console mode stdCall _SetConsoleMode,<[dp+stdIn],eax> ; restore previous console mode, don't worry about err here next key4: stdCall _GetLastError ; on this error, don't worry about console mode mov lastError[dp],eax ; save error return mov eax,UniNotAChar push eax next ;!!!***!!! This still doesn't work right fnamemanque <KEY?> ; -- flag fw_KEY_Q: ; FACILITY docode mov DWORD PTR lastError[dp],TRUE ; No windows error code has all bits set mov eax,256 ; number of records to try for per Microsoft stdCall _PeekConsoleInputW <[dp+stdIn], OFFSET FLAT:inRecArray, eax, OFFSET FLAT:numRead> and eax,eax ; "C" TRUE is success jne keyq1 ; on success, continue further on push eax ; push failure jmp doLastErr ; on failure, return via set error code routine keyq1: mov ecx,[numRead] ; number of input records successfully peeked and ecx,ecx je keyq_none ; none? fergit it! mov eax,OFFSET FLAT:inRecArray keyq2: cmp WORD PTR [eax].EventType,KEY_EVENT ; loop comparing the EvenType field in each struc jne keyq_continue ; not a KEY_EVENT, loop cmp DWORD PTR [eax].bKeyDown,0 ; test if we have a key down jne keyq_found ; if C-language "true", a key is down, we're done keyq_continue: add eax,SIZE INPUT_RECORD loop keyq2 keyq_none: ; nope push FALSE next keyq_found: ; yup push TRUE next fname <TYPE> ; c-addr u -- dd ftype ftype: pop eax pop edx lea edx,[edx][dp] stdCall _WriteConsoleW,<[dp+stdOut],edx,eax,OFFSET FLAT:numWritten,0> jmp SHORT doLastErr ; returns to NEXT via doLastErr fname <EMIT> dd emit emit: pop DWORD PTR [dp+outChar] lea eax,[dp+outChar] stdCall _WriteConsoleW,<[dp+stdOut],eax,1,OFFSET FLAT:numWritten,0> jmp SHORT doLastErr ; returns to NEXT via doLastErr ; Serve these I/O words to set our local LastError variable either TRUE for success or to return from LastError. doLastErr: and eax,eax ; "C" TRUE is success je dLE1 ; on failure, get error code mov DWORD PTR lastError[dp],TRUE ; success, return TRUE next ; No Windows error code has all bits set dLE1: stdCall _GetLastError mov lastError[dp],eax ; save error return next ; Calls factor (ACCEPT), then handles trailing CR/LF pair. fname <ACCEPT> ; c-addr +n1 -- +n2 ctok NEST ctok OVER ctok SWAP ; -- c-a c-a +n1 ctok PACCEPT ; -- c-a +n2' ctok DUP ; -- c-a +n2 +n2 compif accept9 ctok TWO_DUP ; -- c-a +n2 c-a +n2 ctok CHARS ctok PLUS ; -- c-a1 +n2 c-a2 literal 2 literal 0 compdo accept4 accept3: literal 1 ; -- c-a1 +n2 c-a2 1 ctok CHARS ctok MINUS ; -- c-a1 +n2 c-a2' ctok DUP ctok C_FETCH ; -- c-a1 +n2 c-a2' char ctok DUP literal 0aH ; -- c-a1 +n2 c-a2' char char 0aH ctok EQUAL ; -- c-a1 +n2 c-a2' char flag ctok SWAP ; -- c-a1 +n2 c-a2' flag char literal 0dH ; -- c-a1 +n2 c-a2' flag char 0dH ctok EQUAL ; -- c-a1 +n2 c-a2' flag1 flag2 ctok OR ; -- c-a1 +n2 c-a2' flag compif accept8 ctok BL ; -- c-a1 +n2 c-a2' 020H ctok OVER ; -- c-a1 +n2 c-a2' 020H c-a2' ctok C_STORE ; -- c-a1 +n2 c-a2' accept8: comploop accept3 accept4: ; -- c-a1 +n2 c-a2' ctok DROP ; -- c-a1 +n2 accept9: ctok NIP ; -- +n2 accept_done: ctok UNNEST znamemanque <(ACCEPT)> ; c-addr +n1 -- +n2 fw_PACCEPT: ; implementation docode pop eax and eax,eax ; positive count? jnle paccept1 ; if yes, continue further on xor eax,eax ; make a zero mov [esp],eax ; +n2 = 0 on error paccept1: push eax ; preserve count lea eax,[dp+conMode] ; in order to preserve con mode stdCall _GetConsoleMode,<[dp+stdIn],eax> ; let's find out what it is and eax,eax ; success is "C" TRUE jne paccept2 ; if GetConsoleMode succeeds, continue pop eax ; discard count xor eax,eax ; make a zero mov [esp],eax ; n2 = 0 on error jmp doLastErr ; return to NEXT via doLastErr paccept2: stdCall _SetConsoleMode,<[dp+stdIn],ENABLE_ECHO_INPUT OR ENABLE_LINE_INPUT OR ENABLE_PROCESSED_INPUT> ; set echo, line input, processed handling and eax,eax ; success is "C" TRUE jne paccept3 ; if SetConsoleMode succeeds, continue pop eax ; discard count xor eax,eax ; make a zero mov [esp],eax ; n2 = 0 on error jmp doLastErr ; return to NEXT via doLastErr paccept3: pop eax ; count pop edx ; destination add edx,dp ; abs address of destination stdCall _ReadConsoleW,<[dp+stdIn],edx,eax,OFFSET FLAT:numRead,0> ; get a line of input and eax,eax ; "C" TRUE is success jne paccept4 ; on success, continue elsewhere push eax jmp doLastErr ; failure, get error code paccept4: mov DWORD PTR lastError[dp],TRUE ; success, return TRUE, no Windows error code has all bits set mov eax,DWORD PTR numRead ; how many did we get? push eax ; this is: -- +n2 mov eax,conMode[dp] ; get saved console mode stdCall _SetConsoleMode,<[dp+stdIn],eax> ; restore previous console mode, don't worry about err here next ;--( Data Space and the Dictionary ) zname <UNFOUND> ; -- ctok NEST ; Implementation literal wordBuffer ctok COUNT ctok TYPE ctok SPACE charlit '?' ctok EMIT ctok SPACE literal -13 ctok THROW ; Can't use our name header macros with this one! linkme flinkptr countcell 1 db "'",0 ; -- xt | abort align 4 ; CORE fw_TICK: ctok NEST ctok BL ctok WORD ctok FIND ctok ZEROEQ compif tick1 ctok UNFOUND tick1: ctok UNNEST ; Can't use our name header macros with this one! linkme flinkptr countcell <3 or immedMask> db '[',0,"'",0,']',0 ; -- | abort align 4 ; CORE fw_BRACKETTICK: ctok NEST ctok STATEABORT ctok TICK ctok LITERAL ctok UNNEST fname <ALIGN> ; -- ctok NEST ; CORE literal cell ; -- 4 ctok HERE ; -- 4 addr literal cell-1 ; -- 4 addr 3 ctok AND ; -- 4 xx ctok DUP ; -- 4 xx xx compif align1 ; -- 4 xx "extra bits" indicating cell alignment? ctok MINUS ; -- n address now aligned, but a cell short ctok ALLOT ; -- now it's ok ctok EXIT align1: ctok TWO_DROP ; 4 xx -- ctok UNNEST fname <ALIGNED> ; addr -- a-addr ctok NEST ; CORE ctok DUP ; -- a a literal cell-1 ; -- a a n ctok AND ; -- a x ctok DUP ; -- a x x compif aligned1 ; -- a x "extra bits" indicating cell alignment? ctok MINUS ; -- a-a' address now aligned, but a cell short literal cell ; -- a-a' n ctok PLUS ; -- a-a ctok EXIT aligned1: ; -- a-a x no "extra bits" ctok DROP ; -- a-a ctok UNNEST fname <ALLOT> ; n -- dd allot ; CORE allot: pop eax add datap[dp],eax next fnamemanque <CELL+> ; a-addr1 -- a-addr2 fw_CELL_PLUS: ; CORE dd cell_plus cell_plus: add DWORD PTR [esp],cell next fname <CELLS> ; n1 -- n2 ctok NEST ; CORE literal cell ctok STAR ctok UNNEST fnamemanque <FORTH-WORDLIST> ; -- wid fw_FWORDLIST: ; SEARCH ctok DOKWORDLIST dd flinkp ; pointer to data address of of last word added to list dd 0 ; token of next wordlist in link fnamemanque <INTERNALS-WORDLIST> ; -- wid fw_ZWORDLIST: ; Implementation ctok DOKWORDLIST dd zlinkp ; pointer to data address of of last word added to list ctok FWORDLIST ; token of next wordlist in link fnamemanque <NONSTANDARD-WORDLIST> ; -- wid fw_NWORDLIST: ; Implementation ctok DOKWORDLIST dd nlinkp ; pointer to data address of of last word added to list ctok ZWORDLIST ; token of next wordlist in link fnamemanque <SYSTEM-WORDLIST> ; -- wid fw_SWORDLIST: ; Implementation ctok DOKWORDLIST dd slinkp ; pointer to data address of of last word added to list ctok NWORDLIST ; token of next wordlist in link fname <FORTH> ; -- ctok NEST ; SEARCH EXT ctok GET_ORDER ctok QDUP compif forth1 ctok NIP ctok FWORDLIST ctok SWAP ctok SET_ORDER ctok EXIT forth1: ctok FWORDLIST literal 1 ctok SET_ORDER ctok UNNEST fnamemanque <SET-CURRENT> ; wid -- fw_SET_CURRENT: ; SEARCH docode pop DWORD PTR current[dp] ; store wid to the current compilation wordlist variable next fnamemanque <GET-CURRENT> ; -- wid fw_GET_CURRENT: ; SEARCH dd get_current get_current: push DWORD PTR current[dp] next fnamemanque <SET-ORDER> ; wid1 .. widn n -- fw_SET_ORDER: ; SEARCH ctok NEST ctok DUP literal searchOrderSize ctok GREATER ; no bogus indices, please! literal -49 ; search order overflow THROW ctok AND ctok THROW ctok DUP ctok ZEROLT literal -50 ; search order underflow THROW ctok AND ctok THROW literal searchOrderSize literal 0 compqdo set_order1 set_order0: ; loop clearing search order ctok FALSE literal searchOrder ctok I ctok CELLS ctok PLUS ctok STORE comploop set_order0 set_order1: literal 0 compqdo set_order3 ; ?DO since 0 is a legit argument set_order2: ; loop filling cells, (if any literal searchOrder ctok I ctok CELLS ctok PLUS ctok STORE comploop set_order2 set_order3: ctok UNNEST fname <WORDLIST> ; -- wid ctok NEST ; SEARCH literal unnamedHdr ctok ABSTODATA ctok COUNT ctok NAMEWORDLIST ctok UNNEST nname <NAMEWORDLIST> ; c-addr u -- wid ctok NEST ctok HEADER ; make "UNNAMED" header ... ctok LINKIT ; ... and link it in current wordlist ctok DP ctok FETCH ; save dictionary pointer to convert to token for this wordlist ctok DOLIT ctok DOKWORDLIST ; embed wordlist engine ctok COMPCOMMA ctok HERE ; pointer to the link pointer for this wordlist ctok COMPCOMMA literal 1 ctok CELLS ctok ALLOT ; allot storage for that link pointer literal wllink ctok FETCH ctok COMPCOMMA ; compile back pointer to previous wordlist ctok MAKETOKEN ; convert that dictionary pointer sitting on the stack to a user token ctok DUP ; save copy literal wllink ctok STORE ; store that token in the wordlist link pointer as last wordlist added ctok EXECUTE ; return own WID ctok UNNEST nname <WORDLISTS> ; -- ctok NEST ; Not in Standard ctok CR literal wlHdr ctok ABSTODATA ctok COUNT ctok TYPE literal wllink wordlists1: ctok FETCH ctok QDUP compif wordlists2 ctok TOKENTODATA ctok DUP ctok DOT_WID ctok SPACE literal 2 ctok CELLS ctok PLUS compelse wordlists1 wordlists2: ctok CR ctok UNNEST fname <WORDS> ; -- ctok NEST ; TOOLKIT ctok CR literal searchOrder ctok FETCH ; -- wid ctok FETCH ; -- addr of thread words1: ctok FETCH ; -- link-token ctok QDUP ; is it null compif words2 ; if null, we're done ctok DUP ; -- lt lt ctok DOT_WORD ; -- lt ctok TOKENTODATA ; -- a-addr compelse words1 words2: ctok CR ctok UNNEST fnamemanque <GET-ORDER> ; ( -- wid1 .. widn n) fw_GET_ORDER: ; SEARCH ctok NEST literal 0 ; holder, -- 0 literal searchOrderSize ; -- 0 n literal 0 ; -- 0 n 0 compqdo get_order2 get_order0: ; -- 0 literal searchOrder ; -- 0 a-addr ctok I ; -- 0 a-addr n ctok CELLS ; -- 0 a-addr n' ctok PLUS ; -- 0 a-addr' ctok FETCH ; -- 0 wid ctok ZEROEQ ; -- 0 flag compif get_order1 ctok LEAVE ; -- 0 get_order1: ctok ONE_PLUS ; -- 0+1 comploop get_order0 get_order2: ctok DUP ; -- index index literal 0 ; -- index index 0 compqdo get_order4 get_order3: ; -- index ctok DUP ; -- index index ctok ONE_MINUS ; -- index index' ctok CELLS ; -- index n literal searchOrder ; -- index n a-addr ctok PLUS ; -- index a-addr'(last cell with a valid wid in it) ctok I ctok CELLS ctok MINUS ; -- index a-addr'' ctok FETCH ; -- index wid ctok SWAP ; -- wid index comploop get_order3 get_order4: ctok UNNEST fname <ORDER> ; -- ctok NEST ; SEARCH EXT ctok CR literal orderMsg0 ctok ABSTODATA literal orderMsg0Len ctok TYPE ; -- display text ctok GET_ORDER literal 0 compqdo order1 order0: ctok DOT_WID ; -- print each wid and its name comploop order0 order1: ctok CR literal orderMsg1 ctok ABSTODATA literal orderMsg1Len ctok TYPE ; -- display text ctok GET_CURRENT ctok QDUP compif order2 ctok DOT_WID ; -- print each wid order2: ctok CR ctok UNNEST nnamemanque <.NAME> ; c-addr -- fw_DOT_NAME: ; Implementation ctok NEST ctok COUNT literal allNameMasks ctok INVERT ctok AND ctok TYPE ctok SPACE ctok UNNEST nnamemanque <.WID> ; wid -- fw_DOT_WID: ; Implementation ctok NEST ctok DUP ctok EXETONAME ctok DOT_NAME ctok U_DOT ctok UNNEST znamemanque <.WORD> ; link-token -- fw_DOT_WORD: ; Implementation ctok NEST ctok TOKENTODATA ctok LINKTONAME ctok DOT_NAME ctok UNNEST fname <ALSO> ; -- ctok NEST ; SEARCH EXT ctok GET_ORDER ctok OVER ctok SWAP ctok ONE_PLUS ctok SET_ORDER ctok UNNEST fname <PREVIOUS> ; -- ctok NEST ; SEARCH EXT ctok GET_ORDER ctok DUP literal 2 ctok LESS literal -50 ctok AND ctok THROW ; search order underflow THROW ctok NIP ctok ONE_MINUS ctok SET_ORDER ctok UNNEST fname <ONLY> ; -- ctok NEST ; SEARCH EXT ctok FWORDLIST literal 1 ctok SET_ORDER ctok UNNEST fname <DEFINITIONS> ; -- ctok NEST ; SEARCH EXT literal searchOrder ctok FETCH ctok SET_CURRENT ctok UNNEST fnamemanque <SEARCH-WORDLIST> ; c-addr u wid -- 0 | xt 1 | xt -1) fw_SEARCH_WL: ; SEARCH ctok NEST ctok FETCH ; wid is a data address, which address points to address ... ctok FETCH ; .. of data location holding last link in the wordlist search_wl0: ctok DUP ; is link to zero (end of list) compif search_wl_fail ; No, it's a real link ctok TO_R ; save copy of ltoken ctok TWO_DUP ; -- c-a u c-a u R: -- ltoken ctok R_FETCH ; -- c-a u c-a u ltoken R: -- ltoken ctok TOKENTODATA ; -- c-a u c-a u a-a R: -- ltoken ctok LINKTONAME ; -- c-a1 u c-a1 u c-a2 R: -- ltoken ctok DUP ctok TO_R ; -- c-a1 u c-a1 u c-a2 R: -- ltoken name-address ctok COUNT ; -- c-a1 u1 c-a1 u1 c-a2 u2+mask literal allNameMasks ; unmask name count byte ctok INVERT ctok AND ctok COMPARE ; -- c-a1 u1 0|1|-1 R: -- ltoken name-address ctok ZEROEQ ; -- c-a1 u1 flag R: -- ltoken name-address compif search_wl4 ; Zero? We found it ctok TWO_DROP ; -- R: -- ltoken name-address ctok R_FROM ; -- name-address R: -- ltoken ctok C_FETCH ; -- count-word+mask R: -- ltoken literal immedMask ctok AND ; -- bit R: -- ltoken compif search_wl1 literal 1 ; -- 1 R: -- ltoken compelse search_wl2 search_wl1: ; -- -1 R: -- ltoken literal -1 search_wl2: ctok R_FROM ; -- n ltoken ctok DUP ; -- n ltoken ltoken ctok TOKENTODATA ; -- n ltoken a-addr(link) ctok LINKTOEXE ; -- n ltoken a-addr' ctok DATATOABS ; -- n ltoken abs-addr ctok SWAP ; -- n a-addr' ltoken ctok USERTOKENQ ; -- n a-addr' flag compif search_wl3 ; -- is this in user dictionary? ctok ABSTOCODE ; yes, convert to code token ctok MAKETOKEN ; -- n xt search_wl3: ; -- no, abs address is valid xt for kernel words ctok SWAP ; -- xt 1|-1 ctok EXIT search_wl4: ; didn't match, -- c-a1 u1 R: -- ltoken name-address ctok R_FROM ctok DROP ; -- c-a1 u1 R: -- ltoken ctok R_FROM ; -- c-a1 u1 ltoken R: -- ctok TOKENTODATA ; -- c-a u a-addr ctok FETCH ; -- c-a u next-link-tok compelse search_wl0 ; try again search_wl_fail: ; ran out of links, -- c-a u ltoken ctok DROP ctok TWO_DROP ; -- ctok FALSE ; -- 0 ctok UNNEST fname <HERE> ; -- addr dd here ; CORE here: push [dp+datap] next ; Convert token such as link pointer or execution token to data-relative address zname <TOKENTODATA> ; linkt|xt -- a-addr ctok NEST ; Implementation ctok DUP ctok USERTOKENQ compif t_to_data1 ctok DETOKEN ctok CODETODATA ctok EXIT t_to_data1: ctok ABSTODATA ctok UNNEST ; All these convert from one data-relative address to another. LINK is the link address. EXE is the address ; which is represented by the execution token for the word. NAME is the count word address at the head of ; the name field, not the FFFF word before it. zname <EXETOLINK> ; a-addr1 -- a-addr2 ctok NEST ; Implementation ctok EXETONAME ctok NAMETOLINK ctok UNNEST zname <LINKTOEXE> ; a-addr1 -- a-addr2 ctok NEST ; Implementation ctok LINKTONAME ctok NAMETOEXE ctok UNNEST zname <NAMETOLINK> ; c-addr -- a-addr ctok NEST ; Implementation literal 1 ctok CHARS ctok MINUS ; back past the FFFF marker word literal 1 ctok CELLS ctok MINUS ; back to head of link field ctok UNNEST zname <LINKTONAME> ; a-addr -- c-addr ctok NEST ; Implementation literal 1 ctok CELLS ctok PLUS ; past link field literal 1 ctok CHARS ctok PLUS ; past the FFFF marker word ctok UNNEST zname <NAMETOEXE> ; c-addr -- a-addr ctok NEST ctok COUNT literal allNameMasks ctok INVERT ctok AND ; mask out all "funny" bits in count word ctok CHARS ctok PLUS ctok ALIGNED ctok UNNEST zname <EXETONAME> ; a-addr -- c-addr ctok NEST exetoname1: literal 1 ctok CHARS ctok MINUS ctok DUP ctok C_FETCH literal UniNotAChar ctok EQUAL compuntil exetoname1 ctok CHAR_PLUS ctok UNNEST ;--( Interpreter ) fname <BLK> ; -- a-addr ctok DOCONST ; CORE dd var_blk fname <FIND> ; ( c-addr -- c-addr 0 | xt 1 | xt -1 ) ctok NEST ; CORE ctok DUP ; -- $addr ctok C_FETCH ; -- $addr u compif _4find ; IF the count is non-zero literal searchOrder ; -- $addr addr literal cell ; -- $addr addr n ctok MINUS ; back up to one cell before beginning of search order array ctok SWAP ; ptr-to-wid $addr ctok FALSE ; ptr-to-wid $addr 0(place holder for DROP of SEARCH-WORDLIST result in loop) ctok FALSE ; ptr-to-wid $addr 0(place holder for DROP of DUPed flag SEARCH-WORDLIST in loop) literal searchOrderSize ; number of vocabularies in search order literal 0 compdo _3find ; loop until success or run out of search order _0find: ; -- ptr-to-wid $addr 0 0 ctok TWO_DROP ; -- ptr-to-wid $addr literal cell ; -- ptr-to-wid $addr n ctok ROT ; -- $addr n ptr-to-wid ctok PLUS ; -- ptr-to-wid $addr ctok SWAP ; -- ptw $addr ctok OVER ; -- ptr-to-wid $addr ptr-to-wid ctok FETCH ; -- ptw $addr wid|0 ctok QDUP ; we may have reached end of search order compif _1find ; -- ptw $addr wid ,valid vocabulary pointer ctok OVER ; -- ptw $addr wid $addr ctok COUNT ; -- ptw $addr wid c-addr u ctok ROT ; -- ptw $addr c-addr u wid ctok SEARCH_WL ; -- ptw $a1 [[ 0 ]|[ exetok [ -1|1 ]]] ctok DUP ; -- ptw $a1 [[ 0 0 ]|[ exetok [ -1|1 ] [-1|1]]] ctok ZEROEQ compif yfind ctok DUP ; -- ptw $a1 x1 x2 yfind: compelse _2find ; NULL in CONTEXT at this entry _1find: ; -- ptw $addr ,invalid wid ptr, end of order ctok NIP ; -- $addr ctok FALSE ; -- $addr 0 ctok UNLOOP ; -- $addr 0 ctok EXIT ; -- c-addr 0 _2find: ; -- ptw $addr x1 x2 ctok DUP ; -- ptw $addr x1 x2 x2 compif xfind ; -- ptw $addr x [-1|0|1] ctok LEAVE ; -- ptw $a1 x x xfind: comploop _0find _3find: ; -- ptw $a1 xt flag1 ctok ROT ctok DROP ; -- ptw xt flag ctok ROT ctok DROP ; -- xt flag ctok EXIT ; -- xt flag _4find: ; -- $addr the string was null ctok TRUE literal endq ; var that indicates end of input ctok STORE ctok FALSE ; -- c-addr 0 ctok UNNEST nnamemanque <?STACK> ; i*j -- i*j | - fw_QSTACK: ctok NEST ; implementation ctok SP0 ctok FETCH ; original stack pointer ctok SP_FETCH ; current stack pointer literal cell ctok PLUS ; adjusted for presence of orig. stack ptr. on stack ctok U_LESS ; has stack underflowed? compif qstack1 literal -4 ; Stack Underflow Throw ctok THROW qstack1: ctok UNNEST ; no, continue zname <INTERPRET> ; ( --) ctok NEST ; Not in Standard _0inter: ; Begin ctok QSTACK ; -- ctok BL ctok WORD ctok FIND ; -- [ 'word 0 ] | [ cfa 1|-1 ] ctok QDUP ; -- [ 'word 0 ] | [ cfa 1|-1 1|-1] compif _1inter ; -- cfa 1|-1 ctok STATE ctok FETCH ; -- cfa 1|-1 flag compif _9inter ; compiling ctok ZEROLT ; non-immediate? compif _8inter ; yes, compile it ctok COMPCOMMA ; -- compelse _0inter ; -- _8inter: ctok EXECUTE ; -- compelse _0inter ; -- _9inter: ctok DROP ; -- cfa ,interpreting ctok EXECUTE ; -- ,execute found word literal endq ctok FETCH ; -- t|f ,see if input stream exhausted compif _0inter ; -- loop if not exhausted ctok EXIT ; -- ,exhausted? exit INTERPRET _1inter: literal endq ; input stream exhausted? ctok FETCH ; -- c-addr flag compif _5inter ; if yes we're done, else we might be looking at a number ctok DROP ; discard c-addr ctok EXIT ; exit INTERPRET _5inter: ctok COUNT ; -- c-addr1 u1 ctok NUMBER ; -- d flag ctok ZEROEQ ; -- d t|f compif _zinter ; wasn't a number in current base, fail ctok UNFOUND ; show offending lexical item with "?" _zinter: ctok DPL ; -- d a-addr check for double precision ctok FETCH ; -- d [ n | -1 ] ctok TRUE ; -- d [ n | -1 ] TRUE ctok EQUAL ; -- d t|f compif _6inter ; -- ud2 ctok DROP ; -- u ,drop hi-order if not double precis ctok STATE ; -- u addr ctok FETCH ; -- u flag compif _2inter ; -- u ctok LITERAL ; -- compelse _2inter ; -- u _6inter: ctok STATE ; -- ud2 addr ctok FETCH ; -- ud2 flag compif _2inter ; -- ud2 ctok TWO_LITERAL ; -- _2inter: ; Then literal endq ctok FETCH ; -- flag compuntil _0inter ; Until ctok UNNEST fname <EVALUATE> ; i*x c-addr u -- j*x ctok NEST ctok BLK ; Save input on return stack ctok FETCH ctok TO_R ctok TIB ctok TO_R ctok NUMTIB ctok FETCH ctok TO_R ctok TO_IN ctok FETCH ctok TO_R ctok SOURCE_ID ctok FETCH ctok TO_R literal endq ctok FETCH ctok TO_R ctok FALSE literal endq ctok STORE ctok NUMTIB ctok STORE ctok TICK_TIB ctok STORE literal -1 ctok SOURCE_ID ctok STORE ; -- i*x c-addr u R: -- BLK TIB #TIB >IN SOURCE-ID ctok FALSE ctok BLK ctok STORE ctok FALSE ctok TO_IN ctok STORE ctok INTERPRET ; -- j*x R: -- BLK TIB #TIB >IN SOURCE-ID ctok R_FROM ; Restore input spec literal endq ctok STORE ctok R_FROM ctok SOURCE_ID ctok STORE ctok R_FROM ctok TO_IN ctok STORE ctok R_FROM ctok NUMTIB ctok STORE ctok R_FROM ctok TICK_TIB ctok STORE ctok R_FROM ctok BLK ctok STORE ; -- j*x R: -- ctok UNNEST znamemanque <(PARSE)> ; char "ccc<char>" -- c-addr u fw_PPARSE: ctok NEST ; this one skips leading delims ctok SOURCE ; -- ch c-a u , get TIB or current BLOCK & char count ctok TO_IN ; -- ch c-a u a , get addr of current interp inset var ctok FETCH ; -- ch c-a u n , get current inset ctok SLSTRING ; -- ch c-a' u' ctok OVER ; -- ch c-a' u' c-a' Need a copy to increment >IN ctok TO_R ; -- ch c-a' u' R: -- c-a' ctok DUP ; -- ch c-a' u' u' R: -- c-a' ctok ZEROGT ; -- ch c-a' u' t|f R: -- c-a' compif _0parse ; -- ch c-a' u' R: -- c-a' literal 2 ; -- ch c-a' u' 2 R: -- c-a' ctok PICK ; -- ch c-a' u' ch' , copy of delim char R: -- c-a' ctok SKIP ; -- ch c-a'' u'' , skip leading delim R: -- c-a' _9parse: ctok OVER ; -- ch c-a'' u'' c-a'' R: -- c-a' ctok TO_R ; -- ch c-a'' u'' ,save adr of 1st char R: -- c-a' c-a'' ctok ROT ; -- c-a' u'' ch R: -- c-a' c-a'' ctok SCAN ; -- c-a''' u''' R: -- c-a' c-a'' ctok DROP ; -- c-a''' R: -- c-a' c-a'' ctok R_FROM ; -- c-a''' c-a'' R: -- c-a' ctok R_FROM ; -- c-a''' c-a'' c-a' R: -- literal 2 ; -- c-a''' c-a'' c-a' 2 ctok PICK ; -- c-a''' c-a'' c-a' c-a''' ctok SWAP ; -- c-a''' c-a'' c-a''' c-a' ctok MINUS ; -- c-a''' c-a'' n=bytes ctok TWO_SLASH ; -- c-a''' c-a'' n=chars ctok ONE_PLUS ; account for the character itself which was parsed to. ctok TO_IN ; -- c-a''' c-a'' n a ctok PL_STORE ; -- c-a''' c-a'' ctok TUCK ; -- c-a'' c-a''' c-a'' ctok MINUS ; -- c-addr1 bytes ctok TWO_SLASH ; -- c-addr1 u=chars compelse _1parse ; -- ch c-a u R: -- c-a _0parse: ctok R_FROM ctok DROP ; -- ch c-a u R: -- ctok DROP ; -- ch c-a ctok NIP ; -- c-a literal 0 ; -- c-a 0 _1parse: ctok UNNEST fname <PARSE> ; ( char "ccc<char>" -- c-addr u) ctok NEST ; CORE EXT, hits on leading delimiters ctok SOURCE ; -- ch c-a u , get TIB or current BLOCK & char count ctok TO_IN ; -- ch c-a u a , get addr of current interp inset var ctok FETCH ; -- ch c-a u n , get current inset ctok SLSTRING ; -- ch c-a' u' ctok OVER ; -- ch c-a' u' c-a' Need a copy to increment >IN ctok TO_R ; -- ch c-a' u' R: -- c-a' ctok DUP ; -- ch c-a' u' u' R: -- c-a' ctok ZEROGT ; -- ch c-a' u' t|f R: -- c-a' compif _0parse ; -- ch c-a' u' R: -- c-a' compelse _9parse zname <okPrompt> ; i*x -- i*x ctok NEST ; implementation ctok DOKDOTQUOTE dd okPrompt ctok DEPTH ctok DOT ctok UNNEST nnamemanque <..> ; i*x -- fw_DOTDOT: ctok NEST ctok DEPTH literal 0 compqdo dotdot2 dotdot1: ctok U_DOT comploop dotdot1 dotdot2: ctok UNNEST fname <QUIT> ; ( --) ( R: i*x --) ctok NEST ; CORE literal FALSE ctok BLK ; Not BLOCK input ctok STORE literal FALSE ctok SOURCE_ID ; Indicate keyboard input ctok STORE literal FALSE ctok NUMTIB ; indicate that input stream is empty ctok STORE literal FALSE ctok TO_IN ; indicate that input stream is unparsed ctok STORE literal FALSE ctok STATE ; set STATE to interpret ctok STORE literal FALSE literal inDefinition ; we're not in the middle of a : or :NONAME ctok STORE _1quit: ; this is a "begin" ctok CR ; ye olde CR each Forth QUIT literal rpzero ; zero the return stack ctok FETCH ctok RP_STORE ; init the RP stack ctok FIRSTCATCH ; set up initial catch frame literal FALSE literal endq ctok STORE ; reset end-of-input var ctok REFILL ; get a line of input compif _1quit ; loop back if no input line ctok INTERPRET ; execute it ctok STATE ; check STATE ctok FETCH ctok ZEROEQ compif _2quit ctok okPrompt ; say "ok " if interpreting _2quit: compelse _1quit ; and this is an "Again" ;!!!***!!! Needs to be finished when File loading support is added. fname <SOURCE> ; -- c-addr u ctok NEST ; CORE ctok BLK ctok FETCH ctok QDUP compif source1 ctok BLOCK literal blockSize ctok EXIT source1: ; ctok SOURCE_ID ; ctok FETCH ; ... ctok TIB ctok NUMTIB ctok FETCH ctok UNNEST fnamemanque <SOURCE-ID> ; -- a-addr fw_SOURCE_ID: ctok DOCONST ; CORE dd var_srcid fname <TIB> ; -- c-addr ctok NEST ; CORE EXT ctok TICK_TIB ctok FETCH ctok UNNEST ; Can't use our name header macros with this one! linkme nlinkptr countcell 4 db "'",0,'T',0,'I',0,'B',0 ; -- a-addr align 4 ; Not in Standard fw_TICK_TIB: ctok DOCONST dd var_tib fnamemanque <#TIB> ; -- c-addr fw_NUMTIB: ctok DOCONST ; CORE EXT dd var_numtib ; Can't use our name header macros with this one! linkme flinkptr countcell 3 db '>',0,'I',0,'N',0 ; -- a-addr align 4 ; CORE fw_TO_IN: ctok DOCONST dd var_to_in fname <REFILL> ; -- flag ctok NEST ; CORE EXT ctok SOURCE_ID ; check source of input ctok FETCH literal -1 ctok EQUAL ; if it's EVALUATE, exit FALSE compif refill1 ctok FALSE ctok EXIT refill1: ctok BLK ctok FETCH ; -- u ctok QDUP ; -- u u | o compif refill2 ; we get input from the next BLOCK ctok ONE_PLUS ; -- u' ctok DUP ; -- u' u' ctok BLK ; -- u' u' a-addr ctok STORE ; -- u' ctok FALSE ; Reset interpreter values ctok TO_IN ctok STORE ctok FALSE literal endq ctok STORE ctok INVALIDBLOCK ; -- flag, TRUE if invalid block number ctok ZEROEQ ; -- flag, correct sense for REFILL's return ctok EXIT refill2: ; We get input from the terminal ctok FALSE ctok TO_IN ctok STORE ; >IN OFF ctok FALSE literal endq ctok STORE ; END? OFF ctok TIB literal tibsize ctok ACCEPT ; Get as many chars as console can return ctok NUMTIB ; and store to #TIB ctok STORE ctok TRUE ctok UNNEST fname <WORD> ; ( char "ccc<char>" -- c-addr) ctok NEST ; CORE ctok PPARSE ; -- c-addr u literal wordBuffer ; -- c-addr u dest ctok TWO_DUP ; -- c-addr u dest u dest ctok SWAP ; -- src u dest dest u ctok ONE_PLUS ; -- src u dest dest u' taking the count word into account ctok CHARS ; -- src u dest dest n ctok PLUS ; -- src u dest c-addr(past end-of-dest) ctok BL ; -- src u dest c-addr bl ctok SWAP ; -- src u dest bl c-addr ctok C_STORE ; -- src u dest pad string with a blank ctok PLACE ; -- install string literal wordBuffer ; -- c-addr return word buffer addr ctok UNNEST ; Can't use our name header macros with this one! linkme flinkptr countcell <1 or immedMask> db '(',0 align 4 ; "ccc<)>" -- fw_PAREN: ; CORE ctok NEST charlit ')' ctok PARSE ctok TWO_DROP ctok UNNEST ; Can't use our name header macros with this one! linkme flinkptr countcell <1 or immedMask> db '\',0 align 4 ; "ccc<eol>" -- fw_BSLASH: ctok NEST ctok BLK ctok FETCH ; -- n compif bslash2 ctok TO_IN ctok FETCH ; -- n literal 64 ctok MOD ; -- mod ctok QDUP compif bslash1 ; -- n literal 64 ctok SWAP ctok MINUS ; -- diff ctok TO_IN ctok PL_STORE ; -- bslash1: ctok EXIT ; -- bslash2: ctok NUMTIB ; -- a-addr ctok FETCH ; -- n ctok TO_IN ctok STORE ; -- ctok UNNEST ;--( Implementation Addressing Scheme ) ; In this terminology, "Code" is the user dictionary offset from register CP, ; "Data" is the data space offset from register DP (the latter not to be confused with Forth variable DP). ; The system dictionary resides in absolute address space. ; Convert absolute address to reg DP relative offset. sname <ABSTODATA> ; abs-addr -- data-addr dd abstodata ; Implementation abstodata: sub DWORD PTR [esp],dp next ; Convert reg DP relative offset to absolute address. sname <DATATOABS> ; data-addr -- abs-addr dd datatoabs ; Implementation datatoabs: add DWORD PTR [esp],dp next ; Convert absolute address to reg CP relative offset. sname <ABSTOCODE> ; abs-addr -- code-addr dd abstocode ; Implementation abstocode: sub DWORD PTR [esp],cp next ; Convert reg CP relative offset to absolute address. sname <CODETOABS> ; code-addr -- abs-addr dd codetoabs ; Implementation codetoabs: add DWORD PTR [esp],cp next ; Convert reg CP relative code offset to reg DP relative data offset sname <CODETODATA> ; code-addr -- data-addr ctok NEST ; Implementation ctok CODETOABS ctok ABSTODATA ctok UNNEST ; Convert reg DP relative data offset to reg CP relative code offset sname <DATATOCODE> ; data-addr -- code-addr ctok NEST ; Implementation ctok DATATOABS ctok ABSTOCODE ctok UNNEST ; Convert an offset in the user dictionary to a user dict execution token zname <MAKETOKEN> ; code-offset -- user-xt ctok NEST ; Implementation detail literal userdictmask ctok OR ctok UNNEST ; Detect if a given token is from the user dictionary znamemanque <USERTOKEN?> fw_USERTOKENQ: ; xt -- flag ctok NEST literal userdictmask ctok AND ctok ZEROEQ ctok ZEROEQ ctok UNNEST ; Unmask a user dictionary token zname <DETOKEN> ; user-xt -- code-offset ctok NEST literal userdictmask ctok INVERT ctok AND ctok UNNEST ;--( Compiler ) ; Any compiler word with "xt" in the stack args presumes that a valid form of xt is present on the stack in that position. zname <SAVEDEPTH> ; i*x -- i*x ctok NEST ; Implementation ctok SP_FETCH literal cstack ctok STORE ctok UNNEST zname <CHECKDEPTH> ; j*x -- j*x [ 0 | n if stack has changed ] ctok NEST ; Implementation ctok SP_FETCH literal cstack ctok FETCH ctok MINUS ctok UNNEST zname <HEADER> ; c-addr u -- ctok NEST ; Implementation ctok DP ctok FETCH ; -- c-addr u code-offset ctok MAKETOKEN ; -- c-addr u valid-link-token literal last ; -- c-addr u valid-link-token a-addr ctok STORE ; -- c-addr u keep token for last link added to dictionary ctok GET_CURRENT ; -- c-addr u wid ctok FETCH ; -- c-addr u a-addr ctok FETCH ; -- c-addr u token ctok COMPCOMMA ; -- c-addr u compile back-link to previous definiton in wl ctok DUP ; -- c-addr u u literal 16 ctok LSHIFT ; -- c-addr u u<<16 because we are going to store two words as a dword literal 0FFFFH ; -- c-addr u u 0ffff ctok OR ; -- c-addr u 0ffffuuuu ctok COMPCOMMA ; -- c-addr u ctok DP ctok FETCH ; -- c-addr u code-offset ctok CODETODATA ; -- c-addr u a-addr ctok SWAP ; -- c-addr a-addr u ctok CHARS ; -- c-addr a-addr uchars ctok DUP ; -- c-addr a-addr ubytes ubytes ctok TO_R ; -- c-addr a-addr ubytes R: -- ubytes ctok MOVE ; -- R: -- ubytes ctok R_FROM ; -- ubytes R: -- ctok DP ctok FETCH ; -- ubytes code-offset ctok PLUS ; -- n ctok ALIGNED ; -- n' ctok DP ; -- n a-addr ctok STORE ; -- ctok UNNEST zname <LINKIT> ; -- ctok NEST ; Implementation literal last ctok FETCH ctok GET_CURRENT ctok FETCH ctok STORE ctok UNNEST ; This one's why ";" doesn't reset the system variable "nonaming" fname <IMMEDIATE> ; -- ctok NEST ; CORE literal nonaming ctok FETCH literal -32 ; zero-length string THROW ctok AND ctok THROW ; a :NONAME word can't be IMMEDIATE literal last ctok FETCH ctok TOKENTODATA ctok LINKTONAME ctok DUP ctok C_FETCH literal immedMask ctok OR ctok SWAP ctok C_STORE ctok UNNEST ; Can't use our name header macros with this one! linkme flinkptr countcell 1 db ':',0 align 4 ; "name" -- fw_COLON: ; CORE ctok NEST literal inDefinition ctok FETCH compif colon1 literal -29 ctok THROW ; nested compilation colon1: ctok TRUE literal inDefinition ; we're in a : definition now, prevent nested compilation ctok STORE ctok BL ctok WORD ctok COUNT ctok QDUP ctok ZEROEQ compif colonnzero literal -16 ctok THROW colonnzero: ctok FALSE literal nonaming ctok STORE ; this is not a :NONAME defintion ctok HEADER compelse noname1 ; continue on in :NONAME ; Can't use our name header macros with this one! linkme flinkptr countcell 7 db ':',0,'N',0,'O',0,'N',0,'A',0,'M',0,'E',0 align 4 ; -- | xt (when nonaming) fw_noname: ; CORE EXT ctok NEST ctok TRUE literal inDefinition ctok FETCH compif noname0 literal -29 ctok THROW ; nested compilation noname0: literal inDefinition ; we're in a : definition now, prevent nested compilation ctok STORE ctok TRUE literal nonaming ctok STORE ; this is a :NONAME defintion ctok DP ctok FETCH ctok MAKETOKEN literal last ctok STORE ; so semicolon knows what to put on the stack noname1: ; colon ":" jumps here ctok SAVEDEPTH ; save stack depth to be checked by ";" ctok DOLIT ctok NEST ctok COMPCOMMA ctok RBRACKET ctok UNNEST zname <STATEABORT> ; -- ctok NEST ; Implementation ctok STATE ctok FETCH ctok ZEROEQ ; state zero? we're interpreting literal -14 ; Interpreting a compile-only word throw ctok AND ctok THROW ctok UNNEST ; Can't use our name header macros with this one! linkme flinkptr countcell <immedMask or 1> db ';',0 align 4 ; -- | xt (when nonaming) fw_SEMICOLON: ; CORE ctok NEST ctok STATEABORT ctok FALSE literal inDefinition ; we're now out of a : or :NONAME ctok STORE ctok DOLIT ctok UNNEST ctok COMPCOMMA ctok LBRACKET ctok CHECKDEPTH compif semi_done literal -52 ctok THROW ctok EXIT semi_done: literal nonaming ctok FETCH compif semi_named literal last ; unnamed, get xt for last definition and leave on stack ctok FETCH ctok EXIT semi_named: ctok LINKIT ; named, link in to compilation wordlist ctok UNNEST fnamemanque <]> ; -- fw_RBRACKET: ; CORE ctok NEST ctok TRUE ctok STATE ctok STORE ctok UNNEST finamemanque <[> ; -- fw_LBRACKET: ; CORE ctok NEST ctok FALSE ctok STATE ctok STORE ctok UNNEST fname <STATE> ; -- a-addr ctok DOCONST ; CORE dd var_state nname <DP> ; -- a-addr ctok DOCONST ; Not in Standard dd dictp ; Can't use our name header macros with this one! linkme flinkptr countcell 8 db 'C',0,'O',0,'M',0,'P',0,'I',0,'L',0,'E',0,',',0 align 4 ; xt -- fw_COMPCOMMA: ; CORE EXT ctok NEST ctok DP ; -- xt dp ctok DUP ; -- xt dp dp ctok FETCH ; -- xt dp @dp ctok ALIGNED ; -- xt dp @dp' ctok ROT ; -- dp @dp' xt ctok OVER ; -- dp @dp' xt @dp' ctok CODETODATA ; -- dp @dp' xt a-addr ctok STORE ; -- dp @dp' ctok CELL_PLUS ; -- dp @dp'' ctok SWAP ; -- @dp'' dp(a-addr) ctok STORE ; -- ctok UNNEST finame <RECURSE> ; -- ctok NEST ; CORE ctok STATEABORT literal last ctok FETCH ctok TOKENTODATA ctok LINKTOEXE ctok DATATOCODE ctok MAKETOKEN ctok COMPCOMMA ctok UNNEST ; Can't use our name header macros with this one! linkme flinkptr countcell 5 db '>',0,'B',0,'O',0,'D',0,'Y',0 align 4 ; xt -- fw_TO_BODY: ; CORE ctok NEST ctok TOKENTODATA ctok DUP ctok FETCH ctok DUP ctok DOLIT ctok DOCONST ctok EQUAL ctok SWAP ctok DOLIT ctok DODOES ctok EQUAL ctok OR ctok ZEROEQ compif to_body1 literal -31 ctok THROW to_body1: ctok CELL_PLUS ctok FETCH ctok UNNEST fname <CREATE> ; "name" -- ctok NEST ; CORE ctok ALIGN ctok BL ctok WORD ctok COUNT ctok QDUP ctok ZEROEQ compif create1 literal -16 ctok THROW create1: ctok HEADER ctok DOLIT ctok DOCONST ctok COMPCOMMA ctok HERE ctok COMPCOMMA ctok LINKIT ctok UNNEST fname <VARIABLE> ; "name" -- ctok NEST ; CORE ctok CREATE literal 1 ctok CELLS ctok ALLOT ctok UNNEST fname <CONSTANT> ; x "name" -- ctok NEST ; CORE ctok CREATE ctok DP ctok FETCH ctok CODETODATA literal 1 ctok CELLS ctok MINUS ctok STORE ctok UNNEST zname <MAKEDOES> ; xt -- ctok NEST ; Implementation ctok DOLIT ctok DODOES literal last ; Link token left by the execution of CREATE ctok FETCH ctok TOKENTODATA ctok LINKTOEXE ; Link token is now data address of execution vector ctok STORE ; Now execution vector of CREATEd word is overwritten with DODOES ctok COMPCOMMA ; compile the xt for the DOES> body ctok UNNEST ; Can't use our name header macros with this one! linkme flinkptr countcell <5 or immedMask> db 'D',0,'O',0,'E',0,'S',0,'>',0 align 4 ; -- fw_DOES: ; CORE ctok NEST ctok DOLIT ctok DOLIT ctok COMPCOMMA ; we are laying down a literal ctok DP ctok FETCH literal 3 ctok CELLS ctok PLUS ; the literal is the dict pointer plus the cells laid down by DOES> .. ctok COMPCOMMA ; .. up to the code laid down in the DOES> body. ctok DOLIT ctok MAKETOKEN ctok COMPCOMMA ; Then MAKETOKEN has to be executed on that literal at DOES> time ctok DOLIT ctok MAKEDOES ; Resultant xt is consumed by MAKEDOES ctok COMPCOMMA ctok DOLIT ctok EXIT ctok COMPCOMMA ; Then we EXIT the CREATE .. DOES> definition but continue to compile ctok UNNEST finame <LITERAL> ; x -- ctok NEST ; CORE ctok DOLIT ctok DOLIT ctok COMPCOMMA ctok COMPCOMMA ctok UNNEST finamemanque <2LITERAL> ; x x -- fw_TWO_LITERAL: ; DOUBLE ctok NEST ctok DOLIT ctok DODLIT ctok COMPCOMMA ctok COMPCOMMA ctok COMPCOMMA ctok UNNEST finame <POSTPONE> ; "name" -- ctok NEST ; CORE ctok STATEABORT ctok BL ctok WORD ctok FIND ctok DUP ctok ZEROEQ compif postpone1 ctok UNFOUND postpone1: ctok DOLIT ; first of all, compile this code here .. ctok STATEABORT ; ... since .. ctok COMPCOMMA ; ... the POSTPONEd construct should THROW -14 if encountered interpretively. ctok ZEROLT ; -1 is non-IMMEDIATE compif postpone2 ctok LITERAL ctok DOLIT ctok COMPCOMMA ctok COMPCOMMA ctok EXIT postpone2: ; 1 is IMMEDIATE ctok COMPCOMMA ctok UNNEST ;--( Branches ) zname <UNRESOLVED> ; -- ctok NEST ; Implementation literal -22 ctok THROW finame <IF> ; -- orig ctok NEST ; CORE ctok STATEABORT ctok DOLIT ctok DOIF ; -- xt ctok COMPCOMMA ; -- ctok DP ctok FETCH ; -- orig ctok DOLIT ctok UNRESOLVED ; -- orig xt ctok COMPCOMMA ; -- orig ctok UNNEST finame <ELSE> ; orig1 -- orig2 ctok NEST ; CORE ctok STATEABORT ctok DOLIT ctok DOELSE ; -- o1 xt ctok COMPCOMMA ; -- o1 ctok DP ctok FETCH ; -- o1 o2 ctok SWAP ; -- o2 o1 ctok DOLIT ctok UNRESOLVED ; -- o2 o1 xt ctok COMPCOMMA ; -- o2 o1 ctok DP ctok FETCH ; -- o2 o1 resolution ctok MAKETOKEN ; -- o2 o1 xt ctok SWAP ; -- o2 xt o1 ctok CODETODATA ; -- o2 xt a-addr ctok STORE ; -- o2 ctok UNNEST finame <THEN> ; orig -- ctok NEST ; CORE ctok STATEABORT ctok DP ctok FETCH ; -- orig resolution ctok MAKETOKEN ; -- orig xt ctok SWAP ; -- xt orig ctok CODETODATA ; -- xt a-addr ctok STORE ; -- ctok UNNEST finame <BEGIN> ; -- dest ctok NEST ; CORE ctok STATEABORT ctok DP ctok FETCH ; -- dest ctok UNNEST finame <UNTIL> ; dest -- ctok NEST ; CORE ctok STATEABORT ctok DOLIT ctok DOUNTIL ; -- dest xt ctok COMPCOMMA ; -- dest ctok MAKETOKEN ; -- xt ctok COMPCOMMA ; -- ctok UNNEST finame <WHILE> ; dest -- orig dest ctok NEST ; CORE ctok STATEABORT ctok DOLIT ctok DOIF ; -- dest xt ctok COMPCOMMA ; -- dest ctok DP ctok FETCH ; -- dest orig ctok SWAP ; -- orig dest ctok DOLIT ctok UNRESOLVED ; -- orig dest xt ctok COMPCOMMA ; -- orig dest ctok UNNEST finame <REPEAT> ; orig dest -- ctok NEST ; CORE ctok STATEABORT ctok DOLIT ctok DOELSE ; -- o d xt ctok COMPCOMMA ; -- o d ctok MAKETOKEN ; -- o xt ctok COMPCOMMA ; -- o ctok DP ctok FETCH ; -- o resolution ctok MAKETOKEN ; -- o xt ctok SWAP ; -- xt orig ctok CODETODATA ; -- xt a-addr ctok STORE ; -- ctok UNNEST finame <AGAIN> ; dest -- ctok NEST ; CORE EXT ctok STATEABORT ctok DOLIT ctok DOELSE ; -- d xt ctok COMPCOMMA ; -- d ctok MAKETOKEN ; -- xt ctok COMPCOMMA ; -- ctok UNNEST finame <DO> ; -- do-dest ctok NEST ; CORE ctok STATEABORT ctok DOLIT ctok DODO ; -- xt ctok COMPCOMMA ; -- ctok DP ctok FETCH ; -- do-dest ctok DOLIT ctok UNRESOLVED ; -- do-dest xt ctok COMPCOMMA ; -- do-dest ctok UNNEST finamemanque <?DO> ; -- dest fw_QDO: ctok NEST ; CORE ctok STATEABORT ctok DOLIT ctok DOQDO ; -- xt ctok COMPCOMMA ; -- ctok DP ctok FETCH ; -- do-dest ctok DOLIT ctok UNRESOLVED ; -- do-dest xt ctok COMPCOMMA ; -- do-dest ctok UNNEST finame <LOOP> ; dest -- ctok NEST ; CORE ctok STATEABORT ctok DOLIT ctok DOLOOP ; -- dest xt ctok COMPCOMMA ; -- dest ctok DUP ; -- dest dest ctok CELL_PLUS ; -- dest dest' so that it points beyond UNRESOLVED ctok MAKETOKEN ; -- dest xt ctok COMPCOMMA ; -- dest ctok DP ctok FETCH ; -- dest resolution ctok MAKETOKEN ; -- dest xt ctok SWAP ; -- xt dest ctok CODETODATA ; -- xt a-addr ctok STORE ; -- ctok UNNEST finamemanque <+LOOP> ; -- fw_PLUSLOOP: ctok NEST ; CORE ctok STATEABORT ctok DOLIT ctok DOPLUSLOOP ; -- dest xt ctok COMPCOMMA ; -- dest ctok DUP ; -- dest dest ctok CELL_PLUS ; -- dest dest' so that it points beyond UNRESOLVED ctok MAKETOKEN ; -- dest xt ctok COMPCOMMA ; -- dest ctok DP ctok FETCH ; -- dest resolution ctok MAKETOKEN ; -- dest xt ctok SWAP ; -- xt dest ctok CODETODATA ; -- xt a-addr ctok STORE ; -- ctok UNNEST fname <I> ; -- n|u docode ; CORE mov eax,[rp] ; Calculate current loop index add eax,cell[rp] push eax next fname <J> ; -- n|u docode ; CORE mov eax,3*cell[rp] ; Calculate next outermost loop index add eax,4*cell[rp] push eax next fname <LEAVE> docode ; -- R: loop-sys -- poprp ; CORE poprp poprpto ip next fname <UNLOOP> ; -- R: loop-sys -- docode ; CORE poprp poprp poprp next ;--( Exception Handling ) fname <ABORT> ; -- ctok NEST ; CORE ctok TRUE ctok THROW ; no unnest needed! ; Can't use our name header macros with this one! linkme flinkptr countcell <6 or immedMask> db 'A',0,'B',0,'O',0,'R',0,'T',0,'"',0 ; ccc<"> -- align 4 ; CORE fw_ABORT_QUOTE: ctok NEST ctok STATEABORT ctok DOLIT ctok DOIF ; -- xt ctok COMPCOMMA ; -- ctok DP ctok FETCH ; -- orig ctok DOLIT ctok UNRESOLVED ; -- orig xt ctok COMPCOMMA ; -- orig literal -2 ctok LITERAL ctok DP ctok FETCH ctok S_QUOTE ctok CODETODATA ctok DOLIT ctok THROW ctok SWAP ctok STORE ; overwrite the S" execution engine ctok DP ctok FETCH ; -- orig resolution ctok MAKETOKEN ; -- orig xt ctok SWAP ; -- xt orig ctok CODETODATA ; -- xt a-addr ctok STORE ; -- ctok UNNEST fname <CATCH> ; i*x xt -- j*x 0 | i*x n) dd catch ; EXCEPTION catch: pop wp ; execution token fetch edx,lastCatch ; save previous catch pointer pushrp edx ; (1) pushrp esp ; (2) save stack pointer fetch edx,var_tib ; save buffer address pushrp edx ; (3) fetch edx,var_numtib ; save number of chars in input buffer pushrp edx ; (4) fetch edx,var_to_in ; save index into input buffer pushrp edx ; (5) fetch edx,var_srcid ; save source id pushrp edx ; (6) fetch edx,var_blk ; save BLK pushrp edx ; (7) pushrp ip ; (8) save interpretive pointer store lastCatch,rp ; put pointer to this frame in lastCatch variable mov ecx,OFFSET FLAT:uncatch ; routine to recover mov ip,ecx innext ; eax (the wp) already has the token to execute align cell uncatch: ; we only end up here if no THROW intervenes docode ; as if it was a cell in a colon definition pointing to ... docode ; ... a definition which started here ... fetch rp,lastCatch ; restore return pointer from lastCatch, points to frame poprpto ip ; (8) restore IP that was stashed by CATCH poprp ; (7) discard BLK poprp ; (6) discard SOURCE-ID poprp ; (5) discard >IN poprp ; (4) discard #TIB poprp ; (3) discard 'TIB poprp ; (2) discard DSP poprpto eax ; (1) lastCatch store lastCatch,eax xor eax,eax push eax ; 0 return says all is well next fname <THROW> ; k*x n -- k*x | i*x n docode ; EXCEPTION pop edx ; check arg and edx,edx jne throw1 ; zero? continue harmlessly next throw1: ; arg was non-zero fetch rp,lastCatch ; set return stack back to where it was store lastCaught,ip ; save IP pointing to cell following the THROW poprpto ip ; (8) restore IP that was stashed by CATCH poprpto eax ; (7) store var_blk,eax ; restore BLK poprpto eax ; (6) store var_srcid,eax ; restore SOURCE-ID poprpto eax ; (5)) store var_to_in,eax ; restore >IN poprpto eax ; (4) store var_numtib,eax ; restore #TIB poprpto eax ; (3) store var_tib,eax ; restore 'TIB poprpto esp ; (2) restore DSP poprpto eax ; (1) store lastCatch,eax ; restore lastCatch push edx ; the throw code next zname <FIRSTCATCH> ; -- R: -- catch-sys docode ; Implementation xor edx,edx pushrp edx ; there is no previous catch to push in this case pushrp esp ; save stack pointer fetch edx,var_tib ; save buffer address pushrp edx fetch edx,var_numtib ; save number of chars in input buffer pushrp edx fetch edx,var_to_in ; save number of chars in input buffer pushrp edx fetch edx,var_srcid ; save source id pushrp edx fetch edx,var_blk ; save BLK pushrp edx mov eax,OFFSET FLAT:fw_CATCHFIRSTCATCH+cell pushrp eax ; the CATCH of last resort! store lastCatch,rp ; put pointer to this frame in lastCatch variable next ; onwards! zname <CATCHFIRSTCATCH> ; -- ctok NEST ; Implementation ctok DUP literal -2 ; The ABORT" throw ctok EQUAL compif catchfirst1 literal lastCaught ; Get IP which is pointing to pointer to string ctok FETCH ; IP ctok TOKENTODATA ctok FETCH ; data address of counted string ctok COUNT ctok TYPE compelse catchabort ; fall thru into the tail of ABORT throw catchfirst1: ctok DUP literal -1 ; The ABORT throw ctok EQUAL compif catchfirst4 catchabort: ctok SP0 ctok FETCH ctok SP_STORE ctok FIRSTCATCH ; if we hit the LASTCATCH frame, SP=SP0, RP=RP0, etc, just rebuild LASTCATCH ctok QUIT ; just QUIT catchfirst4: ctok DUP literal -4 ctok EQUAL compif catchfirst13 ctok DOKDOTQUOTE ; stack underflow abort dd stackUnderMsg compelse catchabort ; exit via an ABORT catchfirst13: ctok DUP literal -13 ctok EQUAL compif catchfirst14 ctok DOKDOTQUOTE ; undefined word abort dd undefinedMsg compelse catchabort ; exit via an ABORT catchfirst14: ctok DUP literal -14 ctok EQUAL compif catchfirst16 ctok DOKDOTQUOTE ; compile-only abort dd compOnlyMsg compelse catchabort ; exit via an ABORT catchfirst16: ctok DUP literal -16 ctok EQUAL compif catchfirst22 ctok DOKDOTQUOTE ; zero-length name string abort dd zeroStringMsg compelse catchabort ; exit via an ABORT catchfirst22: ctok DUP literal -22 ctok EQUAL compif catchfirst29 ctok DOKDOTQUOTE ; control structure abort dd conStructMsg compelse catchabort ; exit via an ABORT catchfirst29: ctok DUP literal -29 ctok EQUAL compif catchfirst31 ctok FALSE literal inDefinition ; reset internal var indicating : or :NONAME in progress ctok STORE ctok DOKDOTQUOTE ; >BODY on non-CREATE word dd compNestMsg compelse catchabort ; exit via an ABORT catchfirst31: ctok DUP literal -31 ctok EQUAL compif catchfirst33 ctok DOKDOTQUOTE ; >BODY on non-CREATE word dd toBodyMsg compelse catchabort ; exit via an ABORT catchfirst33: ctok DUP literal -33 ctok EQUAL compif catchfirst34 ctok DOKDOTQUOTE ; BLOCK read error dd blockReadMsg compelse catchabort ; exit via an ABORT catchfirst34: ctok DUP literal -34 ctok EQUAL compif catchfirst35 ctok DOKDOTQUOTE ; BLOCK write error dd blockWriteMsg compelse catchabort ; exit via an ABORT catchfirst35: ctok DUP literal -35 ctok EQUAL compif catchfirst37 ctok DOKDOTQUOTE ; BLOCK number error dd blockNumMsg compelse catchabort ; exit via an ABORT catchfirst37: ctok DUP literal -37 ctok EQUAL compif catchfirst49 ctok LastError ctok FETCH ; Error should be in LastError if we reach this point ctok DOKDOTQUOTE ; File I/O exception dd fileIOMsg ; this message needs a trailing space! ctok U_DOT ; Display compelse catchabort ; exit via an ABORT catchfirst49: ctok DUP literal -49 ; search order overflow THROW ctok EQUAL compif catchfirst50 ctok DOKDOTQUOTE dd srchOverMsg compelse catchabort ; exit via an ABORT catchfirst50: ctok DUP literal -50 ; search order underflow THROW ctok EQUAL compif catchfirst52 ctok DOKDOTQUOTE dd srchUnderMsg compelse catchabort ; exit via an ABORT catchfirst52: ctok DUP literal -52 ctok EQUAL compif catchfirst56 ctok DOKDOTQUOTE dd cStackMsg ; control flow stack changed compelse catchabort ; exit via ABORT catchfirst56: ctok DUP literal -56 ctok EQUAL compif catchall ctok DROP ; drop the -56 ctok FIRSTCATCH ; if we hit the LASTCATCH frame, SP=SP0, RP=RP0, etc, just rebuild LASTCATCH ctok QUIT ; just QUIT catchall: ; the catch-all case for THROWs outside those we have handled literal throwMsg ctok ABSTODATA literal throwMsgLen ctok TYPE ctok DOT charlit '@' ctok EMIT ctok SPACE literal lastCaught ctok FETCH literal cell ctok MINUS ctok DOT ctok FIRSTCATCH ; if we hit the LASTCATCH frame, SP=SP0, RP=RP0, etc, just rebuild LASTCATCH ctok QUIT ctok UNNEST ;--( Tools & Utilities ) nname <NOOP> ; -- docode ; Doesn't appear in Standard nop next zname <DUMPLINE> ; a-addr1 -- a-addr2 ctok NEST ctok DUP ctok DUP ; -- a-addr1 a-addr1 ctok FALSE ctok LSHARP ; -- a-addr1 ud literal 8 ctok FALSE compdo dumpline2 dumpline1: ctok SHARP ; -- a-addr1 ud' comploop dumpline1 dumpline2: ctok SHARPR ctok TYPE ; -- a-addr1 print line address ctok SPACE literal 8 literal 0 compdo dumpline4 dumpline3: ; -- addr addr ctok COUNT ; -- addr addr' char ctok FALSE ctok LSHARP ctok SHARP ctok SHARP ctok SHARP ctok SHARP ctok SHARPR ctok TYPE ; -- addr addr' print two bytes as a word ctok SPACE comploop dumpline3 dumpline4: ctok DROP ; -- addr literal 8 literal 0 compdo dumpline6 dumpline5: ctok COUNT literal 0FFh ctok AND ctok DUP literal 01fH ; -- addr' char char 01fh ctok GREATER compif dumplinenochar ctok EMIT compelse dumplinez dumplinenochar: ctok DROP charlit '.' ctok EMIT dumplinez: comploop dumpline5 dumpline6: ctok UNNEST ; -- addr' fname <DUMP> ; addr u -- ctok NEST ; TOOLKIT ctok BASE ; -- addr u a-addr ctok FETCH ; -- addr u n ctok TO_R ; -- addr u R: -- base ctok HEX ctok CR literal dumpHdr ; print a header here ctok ABSTODATA ctok COUNT ctok TYPE ; -- addr u R: -- base ctok CR ctok SWAP ; -- u addr ctok FALSE ; -- u addr 0 literal 16 ; Now align the dump region ctok UMSLMOD ; -- u1 u2r addr/8 ctok SWAP ; -- u addr/8 u2r ctok TO_R ; -- u addr/8 R: -- u2r literal 16 ctok UMSTAR ; -- u addr' 0 R: -- u2r ctok DROP ; -- u addr' R: -- u2r ctok SWAP ; -- addr u R: -- u2r ctok FALSE ; -- addr u 0 R: -- u2r literal 16 ctok UMSLMOD ; -- addr u1r u2q R: -- u2r ctok SWAP ; -- addr u2q u1r R: -- u2r ctok ZERONE ; -- addr u/16 [-1 | 0] R: -- u2r ctok NEGATE ; -- addr u/16 [1 | 0] R: -- u2r ctok PLUS ; -- addr u(number of iterations) R: -- u2r ctok R_FROM ; -- addr u/16 u2r R: -- ctok ZERONE ; -- addr u/16 [1|0] [-1 | 0] ctok NEGATE ; -- addr u/16 [1|0] [1 | 0] ctok PLUS ; -- addr u(number of iterations) ; add line if bytes modded ctok FALSE ; -- addr u/16 0 compdo dump2 ; dump that many lines dump1: ctok DUMPLINE ctok CR ; ctok KEY_Q ; compif dumpcontinue ; ctok LEAVE dumpcontinue: comploop dump1 dump2: ctok DROP ctok R_FROM ctok BASE ctok STORE : -- R: -- ctok UNNEST fname <BYE> ; -- dd byebye ; TOOLKIT EXT byebye: ; exit program fetch ebp,ntConEBP fetch esp,ntConESP fetch eax,memHandle push eax stdCall _LocalUnlock,eax pop eax stdCall _LocalFree,eax pop edi pop esi pop ebx leave stdCall _ExitProcess,0 fnamemanque <AT-XY> ; u1 u2 -- fw_AT_XY: ; FACILITY docode pop eax ; y pop edx ; x shl eax,16 mov ax,dx ; compose COORD wherein Y is higher in mem than X stdCall _SetConsoleCursorPosition,<DWORD PTR stdOut[dp],eax> and eax,eax ; success is "C" TRUE ; je at_xy1 ; if failure, we'll do some more work mov DWORD PTR lastError[dp],-1 ; success, set lastErr next ; success, exit at_xy1: jmp doLastErr ; return to NEXT via doLastErr fname <PAGE> ; -- docode ; FACILITY mov eax,20H ; character to fill with mov edx,32767 ; !!!***!!! HACK HACK HACK we have to calculate this correctly xor ecx,ecx ; Coord for fill, i.e., "0@0" stdCall _FillConsoleOutputCharacterW,<DWORD PTR stdOut[dp],eax,edx,ecx,OFFSET FLAT:numWritten> and eax,eax ; success is "C" TRUE ; je at_xy1 ; failure, exit re-using code above in AT-XY xor eax,eax ; make a "0@0" Coord for next call stdCall _SetConsoleCursorPosition,<DWORD PTR stdOut[dp],eax> and eax,eax ; success is "C" TRUE ; je at_xy1 ; failure, exit re-using code above in AT-XY mov DWORD PTR lastError[dp],-1 ; success, set lastErr next fnamemanque <ENVIRONMENT?> ; c-addr u -- false | i*x true fw_ENVQ: ; CORE ctok NEST ctok TWO_DROP ctok FALSE ; don't know nuttin' ctok UNNEST ;--( File Words ) include jx4files.a ; jax4th.asm is just getting too big! ;--( Platform-Specific Stuff ) ; Copy unicode string to asciiz string in special sys buffer, null terminates sname <ASCIIZ> ; c-addr u -- addr ctok NEST ; Not in Standard, used for syscalls that don't take unicode ctok TUCK ; -- u c-addr u ctok FALSE ; -- u c-addr u 0 compqdo asciiz2 asciiz1: ctok DUP ; -- u c-addr c-addr ctok C_FETCH ; -- u c-addr char literal asciizBuffer ; -- u c-addr char addr ctok I ctok PLUS ; -- u c-addr char addr' ctok B_STORE ; -- u c-addr ctok CHAR_PLUS ; -- u c-addr' comploop asciiz1 asciiz2: ctok DROP ; -- u literal asciizBuffer ; -- u addr ctok PLUS ; -- addr' one past end of byte string ctok FALSE ctok SWAP ; -- 0 addr' ctok B_STORE ; -- literal asciizBuffer ; -- addr buffer holding ascii byte string ctok UNNEST ; Copy ascii string to unicode string in special sys buffer, null terminates sname <UNICODE> ; b-addr u -- addr ctok NEST ; Not in Standard, used for syscalls that don't take unicode ctok TUCK ; -- u b-addr u ctok FALSE ; -- u b-addr u 0 compqdo unicode2 unicode1: ctok DUP ; -- u b-addr b-addr ctok B_FETCH ; -- u b-addr char literal asciizBuffer ; -- u b-addr char c-addr ctok I ctok CHARS ctok PLUS ; -- u c-addr char addr' ctok C_STORE ; -- u c-addr ctok ONE_PLUS ; -- u c-addr' comploop unicode1 unicode2: ctok DROP ; -- u literal asciizBuffer ; -- u addr ctok CHARS ctok PLUS ; -- addr' one past end of byte string ctok FALSE ctok SWAP ; -- 0 addr' ctok C_STORE ; -- literal asciizBuffer ; -- addr buffer holding ascii byte string ctok UNNEST sname <SYSCALL> ; abs-addr -- edx eax docode ; Call addr and return eax and edx pop eax call eax push edx push eax next sname <GetProcAddress> ; [lpszProc | ordinal] hModule -- abs-addr | nil docode ; find a DLL function address from a null-terminated name string call _GetProcAddress@8 ; parameter if ordinal must have zero (0000h) in hi word push eax next sname <LoadLibraryEx> ; dwFlags 0 lpszLibFile -- hModule | 0 docode call _LoadLibraryExW@12 push eax test eax,0 je doLastErr ; if error, set LastError var next sname <FreeLibrary> ; hLibModule -- docode call _FreeLibrary@4 push eax test eax,0 je doLastErr ; if error, set LastError var next sname <ENABLE_LINE_INPUT> ; -- x ctok DOCONST ; Con Mode constant value dd ENABLE_LINE_INPUT sname <ENABLE_ECHO_INPUT> ; -- x ctok DOCONST ; Con Mode constant value dd ENABLE_ECHO_INPUT sname <ENABLE_PROCESSED_INPUT> ; -- x ctok DOCONST ; Con Mode constant value dd ENABLE_PROCESSED_INPUT sname <ENABLE_WINDOW_INPUT> ; -- x ctok DOCONST ; Con Mode constant value dd ENABLE_WINDOW_INPUT sname <ENABLE_MOUSE_INPUT> ; -- x ctok DOCONST ; Con Mode constant value dd ENABLE_MOUSE_INPUT sname <StdIn> ; -- a-addr ctok DOCONST : Con stdin dd stdIn sname <StdOut> ; -- a-addr ctok DOCONST : Con stdout dd stdOut sname <StdErr> ; -- a-addr ctok DOCONST : Con stdErr dd stdErr sname <ConsoleMode> ; -- a-addr ctok DOCONST ; Address of Con Mode variable dd conMode ; Implementation sname <LastError> ; -- a-addr ctok DOCONST ; Address of Last Error variable dd lastError ; Implementation sname <GetConsoleMode> ; -- LastErr | TRUE docode ; Implementation lea eax,[dp+conMode] stdCall _GetConsoleMode,<[dp+stdIn],eax> jmp SHORT retLastErr ; returns to NEXT via doLastErr sname <SetConsoleMode> ; -- LastErr | TRUE docode ; Implementation mov eax,[dp+conMode] stdCall _SetConsoleMode,<[dp+stdIn],eax> jmp SHORT retLastErr ; returns to NEXT via doLastErr ; Set our local LastError variable either TRUE for success or to return from LastError, return same on stack retLastErr: and eax,eax ; "C" TRUE is success je rLE1 ; on failure, get error code mov DWORD PTR lastError[dp],TRUE ; success, return TRUE mov eax,TRUE push TRUE next ; No Windows error code has all bits set rLE1: stdCall _GetLastError mov lastError[dp],eax ; save error return push eax next ;--( Startup & Signoff ) zname <LOGIN> docode stdCall _WriteConsoleW,<[dp+stdErr],OFFSET FLAT:myMsg,myMsgLen,OFFSET FLAT:numWritten,0> next nname <ABOUT> docode stdCall _WriteConsoleW,<[dp+stdErr],OFFSET FLAT:gnuMsg,gnuMsgLen,OFFSET FLAT:numWritten,0> next zname <LOGOFF> docode stdCall _WriteConsoleW,<[dp+stdErr],OFFSET FLAT:byeMsg,byeMsgLen,OFFSET FLAT:numWritten,0> next nname <COLD> ctok NEST cold: ctok GetConsoleMode ; set up our variable that tracks the console input mode ctok DROP ; discard return ctok DECIMAL ; set number conversion base to decimal, set early to aid debugging ctok FALSE ctok BLK ; input is not from a BLOCK file ctok STORE ctok FALSE ctok SOURCE_ID ; input is from keyboard ctok STORE literal ticktib ctok TICK_TIB ; set up pointer to terminal input buffer ctok STORE ctok FALSE ctok NUMTIB ; no chars in terminal input buffer ctok STORE ctok FALSE ctok TO_IN ; no index into zero chars ctok STORE ctok FALSE ctok STATE ; interpreting, not compiling ctok EMPTYBUFFERS ; clear block buffer(s) ctok FALSE literal blockFile ctok STORE ; no active block file ctok STORE ctok FIRSTCATCH ; set up initial catch frame ;!!!***!!! ; ctok BAREBOOTQ ; is this a bare, not load-dictionary boot? ; compif cold1 ; if yes, init search order ctok ONLY ; set default search order ctok DEFINITIONS ; set default compilation order ctok SWORDLIST ctok NWORDLIST ctok FWORDLIST literal 3 ctok SET_ORDER cold1: ctok LSHARP ; set up number conversion buffer ctok PAGE ctok LOGIN ; display signon message including copyright ctok ABOUT ctok okPrompt ctok ABORT ;--( Testing ) ;--( Bootup ) boot: ; initialize system stdCall _LocalAlloc,<LMEM_FIXED,defDataSize+defDictSize> ; get mem for user dictionary & data space push eax ; save mem handle stdCall _LocalLock,eax ; lock the mem mov cp,eax ; return if non-null is user dictionary, must test here lea dp,[eax+defDictSize] ; data space pop eax ; mem handle store memHandle,eax ; save copy of mem handle for later free store ntConEBP,ebp ; preserve EBP store ntConESP,esp ; preserve ESP lea rp,[esp-dStackSize] ; set return stack pointer store rpzero,rp ; save initial return stack stdCall _GetStdHandle,STD_INPUT_HANDLE ; return is handle or INVALID_HANDLE store stdIn,eax ; store handle stdCall _GetStdHandle,STD_OUTPUT_HANDLE ; return is handle or INVALID_HANDLE store stdOut,eax ; store handle stdCall _GetStdHandle,STD_ERROR_HANDLE ; return is handle or INVALID_HANDLE store stdErr,eax ; store handle ; !!!***!!! for now, just fall thru here into bare_boot bare_boot: ; if we aren't loading a saved image store datap,varptr ; set HERE store dictp,0 ; offset end of dictionary store wllink,<OFFSET FLAT:fw_SWORDLIST> ; word list link mov DWORD PTR [dp+flinkp],OFFSET FLAT:flinkptr ; last link in FORTH-WORDLIST mov DWORD PTR [dp+zlinkp],OFFSET FLAT:zlinkptr ; last link in INTERNALS-WORDLIST mov DWORD PTR [dp+nlinkp],OFFSET FLAT:nlinkptr ; last link in NONSTANDARD-WORDLIST mov DWORD PTR [dp+slinkp],OFFSET FLAT:slinkptr ; last link in SYSTEM-WORDLIST mov ecx,searchOrderSize ; set up to clear search order xor eax,eax ; 0 lea edx,searchOrder[dp] ; address of base of search order array bb1: mov [edx],eax ; erase a cell add edx,cell ; increment address loop bb1 ; loop till done dev_boot: mov WORD PTR lastReadConW,UniNotAChar mov ip,OFFSET FLAT:cold next _mainCRTStartup ENDP _TEXT ENDS END